Ruby  2.0.0p247(2013-06-27revision41674)
ext/tk/tcltklib.c
Go to the documentation of this file.
00001 /*
00002  *      tcltklib.c
00003  *              Aug. 27, 1997   Y. Shigehiro
00004  *              Oct. 24, 1997   Y. Matsumoto
00005  */
00006 
00007 #define TCLTKLIB_RELEASE_DATE "2010-08-25"
00008 /* #define CREATE_RUBYTK_KIT */
00009 
00010 #include "ruby.h"
00011 
00012 #ifdef HAVE_RUBY_ENCODING_H
00013 #include "ruby/encoding.h"
00014 #endif
00015 #ifndef RUBY_VERSION
00016 #define RUBY_VERSION "(unknown version)"
00017 #endif
00018 #ifndef RUBY_RELEASE_DATE
00019 #define RUBY_RELEASE_DATE "unknown release-date"
00020 #endif
00021 
00022 #ifdef RUBY_VM
00023 static int rb_thread_critical; /* dummy */
00024 int rb_thread_check_trap_pending();
00025 #else
00026 /* use rb_thread_critical on Ruby 1.8.x */
00027 #include "rubysig.h"
00028 #endif
00029 
00030 #if !defined(RSTRING_PTR)
00031 #define RSTRING_PTR(s) (RSTRING(s)->ptr)
00032 #define RSTRING_LEN(s) (RSTRING(s)->len)
00033 #endif
00034 #if !defined(RSTRING_LENINT)
00035 #define RSTRING_LENINT(s) ((int)RSTRING_LEN(s))
00036 #endif
00037 #if !defined(RARRAY_PTR)
00038 #define RARRAY_PTR(s) (RARRAY(s)->ptr)
00039 #define RARRAY_LEN(s) (RARRAY(s)->len)
00040 #endif
00041 
00042 #ifdef OBJ_UNTRUST
00043 #define RbTk_OBJ_UNTRUST(x)  do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0)
00044 #else
00045 #define RbTk_OBJ_UNTRUST(x)  OBJ_TAINT(x)
00046 #endif
00047 #define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n)))
00048 
00049 #if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM)
00050 /* Ruby 1.8 :: rb_proc_new() was hidden from intern.h at 2008/04/22 */
00051 extern VALUE rb_proc_new _((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE));
00052 #endif
00053 
00054 #undef EXTERN   /* avoid conflict with tcl.h of tcl8.2 or before */
00055 #include <stdio.h>
00056 #ifdef HAVE_STDARG_PROTOTYPES
00057 #include <stdarg.h>
00058 #define va_init_list(a,b) va_start(a,b)
00059 #else
00060 #include <varargs.h>
00061 #define va_init_list(a,b) va_start(a)
00062 #endif
00063 #include <string.h>
00064 
00065 #if !defined HAVE_VSNPRINTF && !defined vsnprintf
00066 #  ifdef WIN32
00067      /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */
00068 #    define vsnprintf _vsnprintf
00069 #  else
00070 #    ifdef HAVE_RUBY_RUBY_H
00071 #      include "ruby/missing.h"
00072 #    else
00073 #      include "missing.h"
00074 #    endif
00075 #  endif
00076 #endif
00077 
00078 #include <tcl.h>
00079 #include <tk.h>
00080 
00081 #ifndef HAVE_RUBY_NATIVE_THREAD_P
00082 #define ruby_native_thread_p() is_ruby_native_thread()
00083 #undef RUBY_USE_NATIVE_THREAD
00084 #else
00085 #define RUBY_USE_NATIVE_THREAD 1
00086 #endif
00087 
00088 #ifndef HAVE_RB_ERRINFO
00089 #define rb_errinfo() (ruby_errinfo+0) /* cannot be l-value */
00090 #else
00091 VALUE rb_errinfo(void);
00092 #endif
00093 #ifndef HAVE_RB_SAFE_LEVEL
00094 #define rb_safe_level() (ruby_safe_level+0)
00095 #endif
00096 #ifndef HAVE_RB_SOURCEFILE
00097 #define rb_sourcefile() (ruby_sourcefile+0)
00098 #endif
00099 
00100 #include "stubs.h"
00101 
00102 #ifndef TCL_ALPHA_RELEASE
00103 #define TCL_ALPHA_RELEASE       0  /* "alpha" */
00104 #define TCL_BETA_RELEASE        1  /* "beta"  */
00105 #define TCL_FINAL_RELEASE       2  /* "final" */
00106 #endif
00107 
00108 static struct {
00109   int major;
00110   int minor;
00111   int type;  /* ALPHA==0, BETA==1, FINAL==2 */
00112   int patchlevel;
00113 } tcltk_version = {0, 0, 0, 0};
00114 
00115 static void
00116 set_tcltk_version()
00117 {
00118     if (tcltk_version.major) return;
00119 
00120     Tcl_GetVersion(&(tcltk_version.major),
00121                    &(tcltk_version.minor),
00122                    &(tcltk_version.patchlevel),
00123                    &(tcltk_version.type));
00124 }
00125 
00126 #if TCL_MAJOR_VERSION >= 8
00127 # ifndef CONST84
00128 #  if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */
00129 #   define CONST84
00130 #  else /* unknown (maybe TCL_VERSION >= 8.5) */
00131 #   ifdef CONST
00132 #    define CONST84 CONST
00133 #   else
00134 #    define CONST84
00135 #   endif
00136 #  endif
00137 # endif
00138 #else  /* TCL_MAJOR_VERSION < 8 */
00139 # ifdef CONST
00140 #  define CONST84 CONST
00141 # else
00142 #  define CONST
00143 #  define CONST84
00144 # endif
00145 #endif
00146 
00147 #ifndef CONST86
00148 # if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5 /* Tcl8.0.x -- 8.5.x */
00149 #  define CONST86
00150 # else
00151 #  define CONST86 CONST84
00152 # endif
00153 #endif
00154 
00155 /* copied from eval.c */
00156 #define TAG_RETURN      0x1
00157 #define TAG_BREAK       0x2
00158 #define TAG_NEXT        0x3
00159 #define TAG_RETRY       0x4
00160 #define TAG_REDO        0x5
00161 #define TAG_RAISE       0x6
00162 #define TAG_THROW       0x7
00163 #define TAG_FATAL       0x8
00164 
00165 /* for ruby_debug */
00166 #define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); }
00167 #define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
00168 fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
00169 #define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
00170 fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); }
00171 /*
00172 #define DUMP1(ARG1)
00173 #define DUMP2(ARG1, ARG2)
00174 #define DUMP3(ARG1, ARG2, ARG3)
00175 */
00176 
00177 /* release date */
00178 static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;
00179 
00180 /* finalize_proc_name */
00181 static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK";
00182 
00183 static void ip_finalize _((Tcl_Interp*));
00184 
00185 static int at_exit = 0;
00186 
00187 #ifdef HAVE_RUBY_ENCODING_H
00188 static VALUE cRubyEncoding;
00189 
00190 /* encoding */
00191 static int ENCODING_INDEX_UTF8;
00192 static int ENCODING_INDEX_BINARY;
00193 #endif
00194 static VALUE ENCODING_NAME_UTF8;
00195 static VALUE ENCODING_NAME_BINARY;
00196 
00197 static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE));
00198 static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE));
00199 static int update_encoding_table _((VALUE, VALUE, VALUE));
00200 static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE));
00201 static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE));
00202 static VALUE encoding_table_get_name _((VALUE, VALUE));
00203 static VALUE encoding_table_get_obj _((VALUE, VALUE));
00204 static VALUE create_encoding_table _((VALUE));
00205 static VALUE ip_get_encoding_table _((VALUE));
00206 
00207 
00208 /* for callback break & continue */
00209 static VALUE eTkCallbackReturn;
00210 static VALUE eTkCallbackBreak;
00211 static VALUE eTkCallbackContinue;
00212 
00213 static VALUE eLocalJumpError;
00214 
00215 static VALUE eTkLocalJumpError;
00216 static VALUE eTkCallbackRetry;
00217 static VALUE eTkCallbackRedo;
00218 static VALUE eTkCallbackThrow;
00219 
00220 static VALUE tcltkip_class;
00221 
00222 static ID ID_at_enc;
00223 static ID ID_at_interp;
00224 
00225 static ID ID_encoding_name;
00226 static ID ID_encoding_table;
00227 
00228 static ID ID_stop_p;
00229 static ID ID_alive_p;
00230 static ID ID_kill;
00231 static ID ID_join;
00232 static ID ID_value;
00233 
00234 static ID ID_call;
00235 static ID ID_backtrace;
00236 static ID ID_message;
00237 
00238 static ID ID_at_reason;
00239 static ID ID_return;
00240 static ID ID_break;
00241 static ID ID_next;
00242 
00243 static ID ID_to_s;
00244 static ID ID_inspect;
00245 
00246 static VALUE ip_invoke_real _((int, VALUE*, VALUE));
00247 static VALUE ip_invoke _((int, VALUE*, VALUE));
00248 static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition));
00249 static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
00250 static VALUE callq_safelevel_handler _((VALUE, VALUE));
00251 
00252 /* Tcl's object type */
00253 #if TCL_MAJOR_VERSION >= 8
00254 static const char Tcl_ObjTypeName_ByteArray[] = "bytearray";
00255 static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray;
00256 
00257 static const char Tcl_ObjTypeName_String[]    = "string";
00258 static CONST86 Tcl_ObjType *Tcl_ObjType_String;
00259 
00260 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
00261 #define IS_TCL_BYTEARRAY(obj)    ((obj)->typePtr == Tcl_ObjType_ByteArray)
00262 #define IS_TCL_STRING(obj)       ((obj)->typePtr == Tcl_ObjType_String)
00263 #define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL)
00264 #endif
00265 #endif
00266 
00267 #ifndef HAVE_RB_HASH_LOOKUP
00268 #define rb_hash_lookup rb_hash_aref
00269 #endif
00270 
00271 /* safe Tcl_Eval and Tcl_GlobalEval */
00272 static int
00273 #ifdef HAVE_PROTOTYPES
00274 tcl_eval(Tcl_Interp *interp, const char *cmd)
00275 #else
00276 tcl_eval(interp, cmd)
00277     Tcl_Interp *interp;
00278     const char *cmd; /* don't have to be writable */
00279 #endif
00280 {
00281     char *buf = strdup(cmd);
00282     int ret;
00283 
00284     Tcl_AllowExceptions(interp);
00285     ret = Tcl_Eval(interp, buf);
00286     free(buf);
00287     return ret;
00288 }
00289 
00290 #undef Tcl_Eval
00291 #define Tcl_Eval tcl_eval
00292 
00293 static int
00294 #ifdef HAVE_PROTOTYPES
00295 tcl_global_eval(Tcl_Interp *interp, const char *cmd)
00296 #else
00297 tcl_global_eval(interp, cmd)
00298     Tcl_Interp *interp;
00299     const char *cmd; /* don't have to be writable */
00300 #endif
00301 {
00302     char *buf = strdup(cmd);
00303     int ret;
00304 
00305     Tcl_AllowExceptions(interp);
00306     ret = Tcl_GlobalEval(interp, buf);
00307     free(buf);
00308     return ret;
00309 }
00310 
00311 #undef Tcl_GlobalEval
00312 #define Tcl_GlobalEval tcl_global_eval
00313 
00314 /* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */
00315 #if TCL_MAJOR_VERSION < 8
00316 #define Tcl_IncrRefCount(obj) (1)
00317 #define Tcl_DecrRefCount(obj) (1)
00318 #endif
00319 
00320 /* Tcl_GetStringResult for tcl7.x or earlier */
00321 #if TCL_MAJOR_VERSION < 8
00322 #define Tcl_GetStringResult(interp) ((interp)->result)
00323 #endif
00324 
00325 /* Tcl_[GS]etVar2Ex for tcl8.0 */
00326 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
00327 static Tcl_Obj *
00328 Tcl_GetVar2Ex(interp, name1, name2, flags)
00329     Tcl_Interp *interp;
00330     CONST char *name1;
00331     CONST char *name2;
00332     int flags;
00333 {
00334     Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
00335 
00336     nameObj1 = Tcl_NewStringObj((char*)name1, -1);
00337     Tcl_IncrRefCount(nameObj1);
00338 
00339     if (name2) {
00340         nameObj2 = Tcl_NewStringObj((char*)name2, -1);
00341         Tcl_IncrRefCount(nameObj2);
00342     }
00343 
00344     retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags);
00345 
00346     if (name2) {
00347         Tcl_DecrRefCount(nameObj2);
00348     }
00349 
00350     Tcl_DecrRefCount(nameObj1);
00351 
00352     return retObj;
00353 }
00354 
00355 static Tcl_Obj *
00356 Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags)
00357     Tcl_Interp *interp;
00358     CONST char *name1;
00359     CONST char *name2;
00360     Tcl_Obj *newValObj;
00361     int flags;
00362 {
00363     Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
00364 
00365     nameObj1 = Tcl_NewStringObj((char*)name1, -1);
00366     Tcl_IncrRefCount(nameObj1);
00367 
00368     if (name2) {
00369         nameObj2 = Tcl_NewStringObj((char*)name2, -1);
00370         Tcl_IncrRefCount(nameObj2);
00371     }
00372 
00373     retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags);
00374 
00375     if (name2) {
00376         Tcl_DecrRefCount(nameObj2);
00377     }
00378 
00379     Tcl_DecrRefCount(nameObj1);
00380 
00381     return retObj;
00382 }
00383 #endif
00384 
00385 /* from tkAppInit.c */
00386 
00387 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4)
00388 #  if !defined __MINGW32__ && !defined __BORLANDC__
00389 /*
00390  * The following variable is a special hack that is needed in order for
00391  * Sun shared libraries to be used for Tcl.
00392  */
00393 
00394 extern int matherr();
00395 int *tclDummyMathPtr = (int *) matherr;
00396 #  endif
00397 #endif
00398 
00399 /*---- module TclTkLib ----*/
00400 
00401 struct invoke_queue {
00402     Tcl_Event ev;
00403     int argc;
00404 #if TCL_MAJOR_VERSION >= 8
00405     Tcl_Obj **argv;
00406 #else /* TCL_MAJOR_VERSION < 8 */
00407     char **argv;
00408 #endif
00409     VALUE interp;
00410     int *done;
00411     int safe_level;
00412     VALUE result;
00413     VALUE thread;
00414 };
00415 
00416 struct eval_queue {
00417     Tcl_Event ev;
00418     char *str;
00419     int len;
00420     VALUE interp;
00421     int *done;
00422     int safe_level;
00423     VALUE result;
00424     VALUE thread;
00425 };
00426 
00427 struct call_queue {
00428     Tcl_Event ev;
00429     VALUE (*func)();
00430     int argc;
00431     VALUE *argv;
00432     VALUE interp;
00433     int *done;
00434     int safe_level;
00435     VALUE result;
00436     VALUE thread;
00437 };
00438 
00439 void
00440 invoke_queue_mark(struct invoke_queue *q)
00441 {
00442     rb_gc_mark(q->interp);
00443     rb_gc_mark(q->result);
00444     rb_gc_mark(q->thread);
00445 }
00446 
00447 void
00448 eval_queue_mark(struct eval_queue *q)
00449 {
00450     rb_gc_mark(q->interp);
00451     rb_gc_mark(q->result);
00452     rb_gc_mark(q->thread);
00453 }
00454 
00455 void
00456 call_queue_mark(struct call_queue *q)
00457 {
00458     int i;
00459 
00460     for(i = 0; i < q->argc; i++) {
00461         rb_gc_mark(q->argv[i]);
00462     }
00463 
00464     rb_gc_mark(q->interp);
00465     rb_gc_mark(q->result);
00466     rb_gc_mark(q->thread);
00467 }
00468 
00469 
00470 static VALUE eventloop_thread;
00471 static Tcl_Interp *eventloop_interp;
00472 #ifdef RUBY_USE_NATIVE_THREAD
00473 Tcl_ThreadId tk_eventloop_thread_id;  /* native thread ID of Tcl interpreter */
00474 #endif
00475 static VALUE eventloop_stack;
00476 static int   window_event_mode = ~0;
00477 
00478 static VALUE watchdog_thread;
00479 
00480 Tcl_Interp  *current_interp;
00481 
00482 /* thread control strategy */
00483 /* multi-tk works with the following settings only ???
00484     : CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
00485     : USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
00486     : DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
00487 */
00488 #ifdef RUBY_USE_NATIVE_THREAD
00489 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
00490 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
00491 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1
00492 #else /* ! RUBY_USE_NATIVE_THREAD */
00493 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
00494 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
00495 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
00496 #endif
00497 
00498 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
00499 static int have_rb_thread_waiting_for_value = 0;
00500 #endif
00501 
00502 /*
00503  *  'event_loop_max' is a maximum events which the eventloop processes in one
00504  *  term of thread scheduling. 'no_event_tick' is the count-up value when
00505  *  there are no event for processing.
00506  *  'timer_tick' is a limit of one term of thread scheduling.
00507  *  If 'timer_tick' == 0, then not use the timer for thread scheduling.
00508  */
00509 #ifdef RUBY_USE_NATIVE_THREAD
00510 #define DEFAULT_EVENT_LOOP_MAX        800/*counts*/
00511 #define DEFAULT_NO_EVENT_TICK          10/*counts*/
00512 #define DEFAULT_NO_EVENT_WAIT           5/*milliseconds ( 1 -- 999 ) */
00513 #define WATCHDOG_INTERVAL              10/*milliseconds ( 1 -- 999 ) */
00514 #define DEFAULT_TIMER_TICK              0/*milliseconds ( 0 -- 999 ) */
00515 #define NO_THREAD_INTERRUPT_TIME      100/*milliseconds ( 1 -- 999 ) */
00516 #else /* ! RUBY_USE_NATIVE_THREAD */
00517 #define DEFAULT_EVENT_LOOP_MAX        800/*counts*/
00518 #define DEFAULT_NO_EVENT_TICK          10/*counts*/
00519 #define DEFAULT_NO_EVENT_WAIT          20/*milliseconds ( 1 -- 999 ) */
00520 #define WATCHDOG_INTERVAL              10/*milliseconds ( 1 -- 999 ) */
00521 #define DEFAULT_TIMER_TICK              0/*milliseconds ( 0 -- 999 ) */
00522 #define NO_THREAD_INTERRUPT_TIME      100/*milliseconds ( 1 -- 999 ) */
00523 #endif
00524 
00525 #define EVENT_HANDLER_TIMEOUT         100/*milliseconds*/
00526 
00527 static int event_loop_max = DEFAULT_EVENT_LOOP_MAX;
00528 static int no_event_tick  = DEFAULT_NO_EVENT_TICK;
00529 static int no_event_wait  = DEFAULT_NO_EVENT_WAIT;
00530 static int timer_tick     = DEFAULT_TIMER_TICK;
00531 static int req_timer_tick = DEFAULT_TIMER_TICK;
00532 static int run_timer_flag = 0;
00533 
00534 static int event_loop_wait_event   = 0;
00535 static int event_loop_abort_on_exc = 1;
00536 static int loop_counter = 0;
00537 
00538 static int check_rootwidget_flag = 0;
00539 
00540 
00541 /* call ruby interpreter */
00542 #if TCL_MAJOR_VERSION >= 8
00543 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
00544 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
00545 #else /* TCL_MAJOR_VERSION < 8 */
00546 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **));
00547 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
00548 #endif
00549 
00550 struct cmd_body_arg {
00551     VALUE receiver;
00552     ID    method;
00553     VALUE args;
00554 };
00555 
00556 /*----------------------------*/
00557 /* use Tcl internal functions */
00558 /*----------------------------*/
00559 #ifndef TCL_NAMESPACE_DEBUG
00560 #define TCL_NAMESPACE_DEBUG 0
00561 #endif
00562 
00563 #if TCL_NAMESPACE_DEBUG
00564 
00565 #if TCL_MAJOR_VERSION >= 8
00566 EXTERN struct TclIntStubs *tclIntStubsPtr;
00567 #endif
00568 
00569 /*-- Tcl_GetCurrentNamespace --*/
00570 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5
00571 /* Tcl7.x doesn't have namespace support.                            */
00572 /* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */
00573 #  ifndef Tcl_GetCurrentNamespace
00574 EXTERN Tcl_Namespace *  Tcl_GetCurrentNamespace _((Tcl_Interp *));
00575 #  endif
00576 #  if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00577 #    ifndef Tcl_GetCurrentNamespace
00578 #      ifndef FunctionNum_of_GetCurrentNamespace
00579 #define FunctionNum_of_GetCurrentNamespace 124
00580 #      endif
00581 struct DummyTclIntStubs_for_GetCurrentNamespace {
00582     int magic;
00583     struct TclIntStubHooks *hooks;
00584     void (*func[FunctionNum_of_GetCurrentNamespace])();
00585     Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
00586 };
00587 
00588 #define Tcl_GetCurrentNamespace \
00589    (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace)
00590 #    endif
00591 #  endif
00592 #endif
00593 
00594 /* namespace check */
00595 /* ip_null_namespace(Tcl_Interp *interp) */
00596 #if TCL_MAJOR_VERSION < 8
00597 #define ip_null_namespace(interp) (0)
00598 #else /* support namespace */
00599 #define ip_null_namespace(interp) \
00600     (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL)
00601 #endif
00602 
00603 /* rbtk_invalid_namespace(tcltkip *ptr) */
00604 #if TCL_MAJOR_VERSION < 8
00605 #define rbtk_invalid_namespace(ptr) (0)
00606 #else /* support namespace */
00607 #define rbtk_invalid_namespace(ptr) \
00608     ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns)
00609 #endif
00610 
00611 /*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/
00612 #if TCL_MAJOR_VERSION >= 8
00613 #  ifndef CallFrame
00614 typedef struct CallFrame {
00615     Tcl_Namespace *nsPtr;
00616     int dummy1;
00617     int dummy2;
00618     char *dummy3;
00619     struct CallFrame *callerPtr;
00620     struct CallFrame *callerVarPtr;
00621     int level;
00622     char *dummy7;
00623     char *dummy8;
00624     int dummy9;
00625     char* dummy10;
00626 } CallFrame;
00627 #  endif
00628 
00629 #  if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
00630 EXTERN int  TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
00631 #  endif
00632 #  if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00633 #    ifndef TclGetFrame
00634 #      ifndef FunctionNum_of_GetFrame
00635 #define FunctionNum_of_GetFrame 32
00636 #      endif
00637 struct DummyTclIntStubs_for_GetFrame {
00638     int magic;
00639     struct TclIntStubHooks *hooks;
00640     void (*func[FunctionNum_of_GetFrame])();
00641     int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **));
00642 };
00643 #define TclGetFrame \
00644    (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame)
00645 #    endif
00646 #  endif
00647 
00648 #  if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
00649 EXTERN void Tcl_PopCallFrame _((Tcl_Interp *));
00650 EXTERN int  Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
00651 #  endif
00652 #  if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00653 #    ifndef Tcl_PopCallFrame
00654 #      ifndef FunctionNum_of_PopCallFrame
00655 #define FunctionNum_of_PopCallFrame 128
00656 #      endif
00657 struct DummyTclIntStubs_for_PopCallFrame {
00658     int magic;
00659     struct TclIntStubHooks *hooks;
00660     void (*func[FunctionNum_of_PopCallFrame])();
00661     void (*tcl_PopCallFrame) _((Tcl_Interp *));
00662     int  (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
00663 };
00664 
00665 #define Tcl_PopCallFrame \
00666    (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame)
00667 #define Tcl_PushCallFrame \
00668    (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame)
00669 #    endif
00670 #  endif
00671 
00672 #else /* Tcl7.x */
00673 #  ifndef CallFrame
00674 typedef struct CallFrame {
00675     Tcl_HashTable varTable;
00676     int level;
00677     int argc;
00678     char **argv;
00679     struct CallFrame *callerPtr;
00680     struct CallFrame *callerVarPtr;
00681 } CallFrame;
00682 #  endif
00683 #  ifndef Tcl_CallFrame
00684 #define Tcl_CallFrame CallFrame
00685 #  endif
00686 
00687 #  if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
00688 EXTERN int  TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
00689 #  endif
00690 
00691 #  if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
00692 typedef struct DummyInterp {
00693     char *dummy1;
00694     char *dummy2;
00695     int  dummy3;
00696     Tcl_HashTable dummy4;
00697     Tcl_HashTable dummy5;
00698     Tcl_HashTable dummy6;
00699     int numLevels;
00700     int maxNestingDepth;
00701     CallFrame *framePtr;
00702     CallFrame *varFramePtr;
00703 } DummyInterp;
00704 
00705 static void
00706 Tcl_PopCallFrame(interp)
00707     Tcl_Interp *interp;
00708 {
00709     DummyInterp *iPtr = (DummyInterp*)interp;
00710     CallFrame *frame = iPtr->varFramePtr;
00711 
00712     /* **** DUMMY **** */
00713     iPtr->framePtr = frame.callerPtr;
00714     iPtr->varFramePtr = frame.callerVarPtr;
00715 
00716     return TCL_OK;
00717 }
00718 
00719 /* dummy */
00720 #define Tcl_Namespace char
00721 
00722 static int
00723 Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame)
00724     Tcl_Interp *interp;
00725     Tcl_CallFrame *framePtr;
00726     Tcl_Namespace *nsPtr;
00727     int isProcCallFrame;
00728 {
00729     DummyInterp *iPtr = (DummyInterp*)interp;
00730     CallFrame *frame = (CallFrame *)framePtr;
00731 
00732     /* **** DUMMY **** */
00733     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
00734     if (iPtr->varFramePtr != NULL) {
00735         frame.level = iPtr->varFramePtr->level + 1;
00736     } else {
00737         frame.level = 1;
00738     }
00739     frame.callerPtr = iPtr->framePtr;
00740     frame.callerVarPtr = iPtr->varFramePtr;
00741     iPtr->framePtr = &frame;
00742     iPtr->varFramePtr = &frame;
00743 
00744     return TCL_OK;
00745 }
00746 #  endif
00747 
00748 #endif
00749 
00750 #endif /* TCL_NAMESPACE_DEBUG */
00751 
00752 
00753 /*---- class TclTkIp ----*/
00754 struct tcltkip {
00755     Tcl_Interp *ip;              /* the interpreter */
00756 #if TCL_NAMESPACE_DEBUG
00757     Tcl_Namespace *default_ns;   /* default namespace */
00758 #endif
00759 #ifdef RUBY_USE_NATIVE_THREAD
00760     Tcl_ThreadId tk_thread_id;   /* native thread ID of Tcl interpreter */
00761 #endif
00762     int has_orig_exit;           /* has original 'exit' command ? */
00763     Tcl_CmdInfo orig_exit_info;  /* command info of original 'exit' command */
00764     int ref_count;               /* reference count of rbtk_preserve_ip call */
00765     int allow_ruby_exit;         /* allow exiting ruby by 'exit' function */
00766     int return_value;            /* return value */
00767 };
00768 
00769 static struct tcltkip *
00770 get_ip(self)
00771     VALUE self;
00772 {
00773     struct tcltkip *ptr;
00774 
00775     Data_Get_Struct(self, struct tcltkip, ptr);
00776     if (ptr == 0) {
00777         /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */
00778         return((struct tcltkip *)NULL);
00779     }
00780     if (ptr->ip == (Tcl_Interp*)NULL) {
00781         /* rb_raise(rb_eRuntimeError, "deleted IP"); */
00782         return((struct tcltkip *)NULL);
00783     }
00784     return ptr;
00785 }
00786 
00787 static int
00788 deleted_ip(ptr)
00789     struct tcltkip *ptr;
00790 {
00791     if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip)
00792 #if TCL_NAMESPACE_DEBUG
00793           || rbtk_invalid_namespace(ptr)
00794 #endif
00795     ) {
00796         DUMP1("ip is deleted");
00797         return 1;
00798     }
00799     return 0;
00800 }
00801 
00802 /* increment/decrement reference count of tcltkip */
00803 static int
00804 rbtk_preserve_ip(ptr)
00805     struct tcltkip *ptr;
00806 {
00807     ptr->ref_count++;
00808     if (ptr->ip == (Tcl_Interp*)NULL) {
00809         /* deleted IP */
00810         ptr->ref_count = 0;
00811     } else {
00812         Tcl_Preserve((ClientData)ptr->ip);
00813     }
00814     return(ptr->ref_count);
00815 }
00816 
00817 static int
00818 rbtk_release_ip(ptr)
00819     struct tcltkip *ptr;
00820 {
00821     ptr->ref_count--;
00822     if (ptr->ref_count < 0) {
00823         ptr->ref_count = 0;
00824     } else if (ptr->ip == (Tcl_Interp*)NULL) {
00825         /* deleted IP */
00826         ptr->ref_count = 0;
00827     } else {
00828         Tcl_Release((ClientData)ptr->ip);
00829     }
00830     return(ptr->ref_count);
00831 }
00832 
00833 
00834 static VALUE
00835 #ifdef HAVE_STDARG_PROTOTYPES
00836 create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
00837 #else
00838 create_ip_exc(interp, exc, fmt, va_alist)
00839     VALUE interp:
00840     VALUE exc;
00841     const char *fmt;
00842     va_dcl
00843 #endif
00844 {
00845     va_list args;
00846     char buf[BUFSIZ];
00847     VALUE einfo;
00848     struct tcltkip *ptr = get_ip(interp);
00849 
00850     va_init_list(args,fmt);
00851     vsnprintf(buf, BUFSIZ, fmt, args);
00852     buf[BUFSIZ - 1] = '\0';
00853     va_end(args);
00854     einfo = rb_exc_new2(exc, buf);
00855     rb_ivar_set(einfo, ID_at_interp, interp);
00856     if (ptr) {
00857         Tcl_ResetResult(ptr->ip);
00858     }
00859 
00860     return einfo;
00861 }
00862 
00863 
00864 /*####################################################################*/
00865 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
00866 
00867 /*--------------------------------------------------------*/
00868 
00869 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84
00870 #error Ruby/Tk-Kit requires Tcl/Tk8.4 or later.
00871 #endif
00872 
00873 /*--------------------------------------------------------*/
00874 
00875 /* Many part of code to support Ruby/Tk-Kit is quoted from Tclkit.       */
00876 /* But, never ask Tclkit community about Ruby/Tk-Kit.                    */
00877 /* Please ask Ruby (Ruby/Tk) community (e.g. "ruby-dev" mailing list).   */
00878 /*
00879 ----<< license terms of TclKit (from kitgen's "README" file) >>---------------
00880 The Tclkit-specific sources are license free, they just have a copyright. Hold
00881 the author(s) harmless and any lawful use is permitted.
00882 
00883 This does *not* apply to any of the sources of the other major Open Source
00884 Software used in Tclkit, which each have very liberal BSD/MIT-like licenses:
00885 
00886   * Tcl/Tk, TclVFS, Thread, Vlerq, Zlib
00887 ------------------------------------------------------------------------------
00888  */
00889 /* Tcl/Tk stubs may work, but probably it is meaningless. */
00890 #if defined USE_TCL_STUBS || defined USE_TK_STUBS
00891 #  error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit.
00892 #endif
00893 
00894 #ifndef KIT_INCLUDES_ZLIB
00895 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
00896 #define KIT_INCLUDES_ZLIB 1
00897 #else
00898 #define KIT_INCLUDES_ZLIB 0
00899 #endif
00900 #endif
00901 
00902 #ifdef _WIN32
00903 #define WIN32_LEAN_AND_MEAN
00904 #include <windows.h>
00905 #undef WIN32_LEAN_AND_MEAN
00906 #endif
00907 
00908 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
00909 EXTERN Tcl_Obj* TclGetStartupScriptPath();
00910 EXTERN void TclSetStartupScriptPath _((Tcl_Obj*));
00911 #define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath()
00912 #define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path)
00913 #endif
00914 #if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED)
00915 EXTERN char* TclSetPreInitScript _((char *));
00916 #endif
00917 
00918 #ifndef KIT_INCLUDES_TK
00919 #  define KIT_INCLUDES_TK  1
00920 #endif
00921 /* #define KIT_INCLUDES_ITCL 1 */
00922 /* #define KIT_INCLUDES_THREAD  1 */
00923 
00924 Tcl_AppInitProc Vfs_Init, Rechan_Init;
00925 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
00926 Tcl_AppInitProc Pwb_Init;
00927 #endif
00928 
00929 #ifdef KIT_LITE
00930 Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit;
00931 #else
00932 Tcl_AppInitProc Mk4tcl_Init;
00933 #endif
00934 
00935 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
00936 Tcl_AppInitProc Thread_Init;
00937 #endif
00938 
00939 #if KIT_INCLUDES_ZLIB
00940 Tcl_AppInitProc Zlib_Init;
00941 #endif
00942 
00943 #ifdef KIT_INCLUDES_ITCL
00944 Tcl_AppInitProc Itcl_Init;
00945 #endif
00946 
00947 #ifdef _WIN32
00948 Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init;
00949 #endif
00950 
00951 /*--------------------------------------------------------*/
00952 
00953 #define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH"
00954 
00955 static char *rubytk_kitpath = NULL;
00956 
00957 static char rubytkkit_preInitCmd[] =
00958 "proc tclKitPreInit {} {\n"
00959     "rename tclKitPreInit {}\n"
00960     "load {} rubytk_kitpath\n"
00961 #if KIT_INCLUDES_ZLIB
00962     "catch {load {} zlib}\n"
00963 #endif
00964 #ifdef KIT_LITE
00965     "load {} vlerq\n"
00966     "namespace eval ::vlerq {}\n"
00967     "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n"
00968       "set n -1\n"
00969     "} else {\n"
00970       "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n"
00971       "set n [lsearch [vlerq get $files * name] boot.tcl]\n"
00972     "}\n"
00973     "if {$n >= 0} {\n"
00974         "array set a [vlerq get $files $n]\n"
00975 #else
00976     "load {} Mk4tcl\n"
00977 #if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT
00978     /* running command cannot open itself for writing */
00979     "mk::file open exe $::tcl::kitpath\n"
00980 #else
00981     "mk::file open exe $::tcl::kitpath -readonly\n"
00982 #endif
00983     "set n [mk::select exe.dirs!0.files name boot.tcl]\n"
00984     "if {[llength $n] == 1} {\n"
00985         "array set a [mk::get exe.dirs!0.files!$n]\n"
00986 #endif
00987         "if {![info exists a(contents)]} { error {no boot.tcl file} }\n"
00988         "if {$a(size) != [string length $a(contents)]} {\n"
00989                 "set a(contents) [zlib decompress $a(contents)]\n"
00990         "}\n"
00991         "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n"
00992         "uplevel #0 $a(contents)\n"
00993 #if 0
00994     "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n"
00995         "uplevel #0 { source [lindex $::argv 1] }\n"
00996         "exit\n"
00997 #endif
00998     "} else {\n"
00999         /* When cannot find VFS data, try to use a real directory */
01000         "set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n"
01001         "if {[file isdirectory $vfsdir]} {\n"
01002            "set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n"
01003            "set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n"
01004            "catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n"
01005            "uplevel #0 [list source [file join $::tcl_library init.tcl]]\n"
01006            "set ::auto_path $::tcl_libPath\n"
01007         "} else {\n"
01008            "error \"\n  $::tcl::kitpath has no VFS data to start up\"\n"
01009         "}\n"
01010     "}\n"
01011 "}\n"
01012 "tclKitPreInit"
01013 ;
01014 
01015 #if 0
01016 /* Not use this script.
01017    It's a memo to support an initScript for Tcl interpreters in the future. */
01018 static const char initScript[] =
01019 "if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n"
01020     "if {[info commands console] != {}} { console hide }\n"
01021     "set tcl_interactive 0\n"
01022     "incr argc\n"
01023     "set argv [linsert $argv 0 $argv0]\n"
01024     "set argv0 [file join $::tcl::kitpath main.tcl]\n"
01025 "} else continue\n"
01026 ;
01027 #endif
01028 
01029 /*--------------------------------------------------------*/
01030 
01031 static char*
01032 set_rubytk_kitpath(const char *kitpath)
01033 {
01034   if (kitpath) {
01035     int len = (int)strlen(kitpath);
01036     if (rubytk_kitpath) {
01037       ckfree(rubytk_kitpath);
01038     }
01039 
01040     rubytk_kitpath = (char *)ckalloc(len + 1);
01041     memcpy(rubytk_kitpath, kitpath, len);
01042     rubytk_kitpath[len] = '\0';
01043   }
01044   return rubytk_kitpath;
01045 }
01046 
01047 /*--------------------------------------------------------*/
01048 
01049 #ifdef WIN32
01050 #define DEV_NULL "NUL"
01051 #else
01052 #define DEV_NULL "/dev/null"
01053 #endif
01054 
01055 static void
01056 check_tclkit_std_channels()
01057 {
01058     Tcl_Channel chan;
01059 
01060     /*
01061      * We need to verify if we have the standard channels and create them if
01062      * not.  Otherwise internals channels may get used as standard channels
01063      * (like for encodings) and panic.
01064      */
01065     chan = Tcl_GetStdChannel(TCL_STDIN);
01066     if (chan == NULL) {
01067         chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0);
01068         if (chan != NULL) {
01069             Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01070         }
01071         Tcl_SetStdChannel(chan, TCL_STDIN);
01072     }
01073     chan = Tcl_GetStdChannel(TCL_STDOUT);
01074     if (chan == NULL) {
01075         chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
01076         if (chan != NULL) {
01077             Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01078         }
01079         Tcl_SetStdChannel(chan, TCL_STDOUT);
01080     }
01081     chan = Tcl_GetStdChannel(TCL_STDERR);
01082     if (chan == NULL) {
01083         chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
01084         if (chan != NULL) {
01085             Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01086         }
01087         Tcl_SetStdChannel(chan, TCL_STDERR);
01088     }
01089 }
01090 
01091 /*--------------------------------------------------------*/
01092 
01093 static int
01094 rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
01095 {
01096     const char* str;
01097     if (objc == 2) {
01098         set_rubytk_kitpath(Tcl_GetString(objv[1]));
01099     } else if (objc > 2) {
01100         Tcl_WrongNumArgs(interp, 1, objv, "?path?");
01101     }
01102     str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable();
01103     Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1));
01104     return TCL_OK;
01105 }
01106 
01107 /*
01108  * Public entry point for ::tcl::kitpath.
01109  * Creates both link variable name and Tcl command ::tcl::kitpath.
01110  */
01111 static int
01112 rubytk_kitpath_init(Tcl_Interp *interp)
01113 {
01114     Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0);
01115     if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath,
01116                 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
01117         Tcl_ResetResult(interp);
01118     }
01119 
01120     Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0);
01121     if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath,
01122                 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
01123         Tcl_ResetResult(interp);
01124     }
01125 
01126     if (rubytk_kitpath == NULL) {
01127         /*
01128          * XXX: We may want to avoid doing this to allow tcl::kitpath calls
01129          * XXX: to obtain changes in nameofexe, if they occur.
01130          */
01131         set_rubytk_kitpath(Tcl_GetNameOfExecutable());
01132     }
01133 
01134     return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0");
01135 }
01136 
01137 /*--------------------------------------------------------*/
01138 
01139 static void
01140 init_static_tcltk_packages()
01141 {
01142     /*
01143      * Ensure that std channels exist (creating them if necessary)
01144      */
01145     check_tclkit_std_channels();
01146 
01147 #ifdef KIT_INCLUDES_ITCL
01148     Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
01149 #endif
01150 #ifdef KIT_LITE
01151     Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit);
01152 #else
01153     Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
01154 #endif
01155 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
01156     Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
01157 #endif
01158     Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL);
01159     Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
01160     Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
01161 #if KIT_INCLUDES_ZLIB
01162     Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
01163 #endif
01164 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
01165     Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
01166 #endif
01167 #ifdef _WIN32
01168 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
01169     Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
01170 #else
01171     Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
01172 #endif
01173     Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
01174 #endif
01175 #ifdef KIT_INCLUDES_TK
01176     Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
01177 #endif
01178 }
01179 
01180 /*--------------------------------------------------------*/
01181 
01182 static int
01183 call_tclkit_init_script(Tcl_Interp  *interp)
01184 {
01185 #if 0
01186   /* Currently, do nothing in this function.
01187      It's a memo (quoted from kitInit.c of Tclkit)
01188      to support an initScript for Tcl interpreters in the future. */
01189   if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
01190     const char *encoding = NULL;
01191     Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
01192     Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
01193     if (path == NULL) {
01194       Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
01195     }
01196   }
01197 #endif
01198 
01199   return 1;
01200 }
01201 
01202 /*--------------------------------------------------------*/
01203 
01204 #ifdef __WIN32__
01205 /* #include <tkWinInt.h> *//* conflict definition of struct timezone */
01206 /* #include <tkIntPlatDecls.h> */
01207 /* #include <windows.h> */
01208 EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance);
01209 void rbtk_win32_SetHINSTANCE(const char *module_name)
01210 {
01211   /* TCHAR szBuf[256]; */
01212   HINSTANCE hInst;
01213 
01214   /* hInst = GetModuleHandle(NULL); */
01215   /* hInst = GetModuleHandle("tcltklib.so"); */
01216   hInst = GetModuleHandle(module_name);
01217   TkWinSetHINSTANCE(hInst);
01218 
01219   /* GetModuleFileName(hInst, szBuf, sizeof(szBuf) / sizeof(TCHAR)); */
01220   /* MessageBox(NULL, szBuf, TEXT("OK"), MB_OK); */
01221 }
01222 #endif
01223 
01224 /*--------------------------------------------------------*/
01225 
01226 static void
01227 setup_rubytkkit()
01228 {
01229   init_static_tcltk_packages();
01230 
01231   {
01232     ID const_id;
01233     const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME);
01234 
01235     if (rb_const_defined(rb_cObject, const_id)) {
01236       volatile VALUE pathobj;
01237       pathobj = rb_const_get(rb_cObject, const_id);
01238 
01239       if (rb_obj_is_kind_of(pathobj, rb_cString)) {
01240 #ifdef HAVE_RUBY_ENCODING_H
01241         pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding());
01242 #endif
01243         set_rubytk_kitpath(RSTRING_PTR(pathobj));
01244       }
01245     }
01246   }
01247 
01248 #ifdef CREATE_RUBYTK_KIT
01249   if (rubytk_kitpath == NULL) {
01250 #ifdef __WIN32__
01251     /* rbtk_win32_SetHINSTANCE("tcltklib.so"); */
01252     {
01253       volatile VALUE basename;
01254       basename = rb_funcall(rb_cFile, rb_intern("basename"), 1,
01255                             rb_str_new2(rb_sourcefile()));
01256       rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename));
01257     }
01258 #endif
01259     set_rubytk_kitpath(rb_sourcefile());
01260   }
01261 #endif
01262 
01263   if (rubytk_kitpath == NULL) {
01264     set_rubytk_kitpath(Tcl_GetNameOfExecutable());
01265   }
01266 
01267   TclSetPreInitScript(rubytkkit_preInitCmd);
01268 }
01269 
01270 /*--------------------------------------------------------*/
01271 
01272 #endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */
01273 /*####################################################################*/
01274 
01275 
01276 /**********************************************************************/
01277 
01278 /* stub status */
01279 static void
01280 tcl_stubs_check()
01281 {
01282     if (!tcl_stubs_init_p()) {
01283         int st = ruby_tcl_stubs_init();
01284         switch(st) {
01285         case TCLTK_STUBS_OK:
01286             break;
01287         case NO_TCL_DLL:
01288             rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
01289         case NO_FindExecutable:
01290             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
01291         case NO_CreateInterp:
01292             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
01293         case NO_DeleteInterp:
01294             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
01295         case FAIL_CreateInterp:
01296             rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()");
01297         case FAIL_Tcl_InitStubs:
01298             rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
01299         default:
01300             rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st);
01301         }
01302     }
01303 }
01304 
01305 
01306 static VALUE
01307 tcltkip_init_tk(interp)
01308     VALUE interp;
01309 {
01310     struct tcltkip *ptr = get_ip(interp);
01311 
01312 #if TCL_MAJOR_VERSION >= 8
01313     int  st;
01314 
01315     if (Tcl_IsSafe(ptr->ip)) {
01316         DUMP1("Tk_SafeInit");
01317         st = ruby_tk_stubs_safeinit(ptr->ip);
01318         switch(st) {
01319         case TCLTK_STUBS_OK:
01320             break;
01321         case NO_Tk_Init:
01322             return rb_exc_new2(rb_eLoadError,
01323                                "tcltklib: can't find Tk_SafeInit()");
01324         case FAIL_Tk_Init:
01325             return create_ip_exc(interp, rb_eRuntimeError,
01326                                  "tcltklib: fail to Tk_SafeInit(). %s",
01327                                  Tcl_GetStringResult(ptr->ip));
01328         case FAIL_Tk_InitStubs:
01329             return create_ip_exc(interp, rb_eRuntimeError,
01330                                  "tcltklib: fail to Tk_InitStubs(). %s",
01331                                  Tcl_GetStringResult(ptr->ip));
01332         default:
01333             return create_ip_exc(interp, rb_eRuntimeError,
01334                                  "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st);
01335         }
01336     } else {
01337         DUMP1("Tk_Init");
01338         st = ruby_tk_stubs_init(ptr->ip);
01339         switch(st) {
01340         case TCLTK_STUBS_OK:
01341             break;
01342         case NO_Tk_Init:
01343             return rb_exc_new2(rb_eLoadError,
01344                                "tcltklib: can't find Tk_Init()");
01345         case FAIL_Tk_Init:
01346             return create_ip_exc(interp, rb_eRuntimeError,
01347                                  "tcltklib: fail to Tk_Init(). %s",
01348                                  Tcl_GetStringResult(ptr->ip));
01349         case FAIL_Tk_InitStubs:
01350             return create_ip_exc(interp, rb_eRuntimeError,
01351                                  "tcltklib: fail to Tk_InitStubs(). %s",
01352                                  Tcl_GetStringResult(ptr->ip));
01353         default:
01354             return create_ip_exc(interp, rb_eRuntimeError,
01355                                  "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
01356         }
01357     }
01358 
01359 #else /* TCL_MAJOR_VERSION < 8 */
01360     DUMP1("Tk_Init");
01361     if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) {
01362         return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
01363     }
01364 #endif
01365 
01366 #ifdef RUBY_USE_NATIVE_THREAD
01367     ptr->tk_thread_id = Tcl_GetCurrentThread();
01368 #endif
01369 
01370     return Qnil;
01371 }
01372 
01373 
01374 /* treat excetiopn on Tcl side */
01375 static VALUE rbtk_pending_exception;
01376 static int rbtk_eventloop_depth = 0;
01377 static int rbtk_internal_eventloop_handler = 0;
01378 
01379 
01380 static int
01381 pending_exception_check0()
01382 {
01383     volatile VALUE exc = rbtk_pending_exception;
01384 
01385     if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
01386         DUMP1("find a pending exception");
01387         if (rbtk_eventloop_depth > 0
01388             || rbtk_internal_eventloop_handler > 0
01389             ) {
01390             return 1; /* pending */
01391         } else {
01392             rbtk_pending_exception = Qnil;
01393 
01394             if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
01395                 DUMP1("pending_exception_check0: call rb_jump_tag(retry)");
01396                 rb_jump_tag(TAG_RETRY);
01397             } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
01398                 DUMP1("pending_exception_check0: call rb_jump_tag(redo)");
01399                 rb_jump_tag(TAG_REDO);
01400             } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
01401                 DUMP1("pending_exception_check0: call rb_jump_tag(throw)");
01402                 rb_jump_tag(TAG_THROW);
01403             }
01404 
01405             rb_exc_raise(exc);
01406         }
01407     } else {
01408         return 0;
01409     }
01410 
01411     UNREACHABLE;
01412 }
01413 
01414 static int
01415 pending_exception_check1(thr_crit_bup, ptr)
01416     int thr_crit_bup;
01417     struct tcltkip *ptr;
01418 {
01419     volatile VALUE exc = rbtk_pending_exception;
01420 
01421     if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
01422         DUMP1("find a pending exception");
01423 
01424         if (rbtk_eventloop_depth > 0
01425             || rbtk_internal_eventloop_handler > 0
01426             ) {
01427             return 1; /* pending */
01428         } else {
01429             rbtk_pending_exception = Qnil;
01430 
01431             if (ptr != (struct tcltkip *)NULL) {
01432                 /* Tcl_Release(ptr->ip); */
01433                 rbtk_release_ip(ptr);
01434             }
01435 
01436             rb_thread_critical = thr_crit_bup;
01437 
01438             if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
01439                 DUMP1("pending_exception_check1: call rb_jump_tag(retry)");
01440                 rb_jump_tag(TAG_RETRY);
01441             } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
01442                 DUMP1("pending_exception_check1: call rb_jump_tag(redo)");
01443                 rb_jump_tag(TAG_REDO);
01444             } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
01445                 DUMP1("pending_exception_check1: call rb_jump_tag(throw)");
01446                 rb_jump_tag(TAG_THROW);
01447             }
01448             rb_exc_raise(exc);
01449         }
01450     } else {
01451         return 0;
01452     }
01453 
01454     UNREACHABLE;
01455 }
01456 
01457 
01458 /* call original 'exit' command */
01459 static void
01460 call_original_exit(ptr, state)
01461     struct tcltkip *ptr;
01462     int state;
01463 {
01464     int  thr_crit_bup;
01465     Tcl_CmdInfo *info;
01466 #if TCL_MAJOR_VERSION >= 8
01467     Tcl_Obj *cmd_obj;
01468     Tcl_Obj *state_obj;
01469 #endif
01470     DUMP1("original_exit is called");
01471 
01472     if (!(ptr->has_orig_exit)) return;
01473 
01474     thr_crit_bup = rb_thread_critical;
01475     rb_thread_critical = Qtrue;
01476 
01477     Tcl_ResetResult(ptr->ip);
01478 
01479     info = &(ptr->orig_exit_info);
01480 
01481     /* memory allocation for arguments of this command */
01482 #if TCL_MAJOR_VERSION >= 8
01483     state_obj = Tcl_NewIntObj(state);
01484     Tcl_IncrRefCount(state_obj);
01485 
01486     if (info->isNativeObjectProc) {
01487         Tcl_Obj **argv;
01488 #define USE_RUBY_ALLOC 0
01489 #if USE_RUBY_ALLOC
01490         argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3);
01491 #else /* not USE_RUBY_ALLOC */
01492         argv = RbTk_ALLOC_N(Tcl_Obj *, 3);
01493 #if 0 /* use Tcl_Preserve/Release */
01494         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
01495 #endif
01496 #endif
01497         cmd_obj = Tcl_NewStringObj("exit", 4);
01498         Tcl_IncrRefCount(cmd_obj);
01499 
01500         argv[0] = cmd_obj;
01501         argv[1] = state_obj;
01502         argv[2] = (Tcl_Obj *)NULL;
01503 
01504         ptr->return_value
01505             = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv);
01506 
01507         Tcl_DecrRefCount(cmd_obj);
01508 
01509 #if USE_RUBY_ALLOC
01510         xfree(argv);
01511 #else /* not USE_RUBY_ALLOC */
01512 #if 0 /* use Tcl_EventuallyFree */
01513         Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
01514 #else
01515 #if 0 /* use Tcl_Preserve/Release */
01516         Tcl_Release((ClientData)argv); /* XXXXXXXX */
01517 #else
01518         /* free(argv); */
01519         ckfree((char*)argv);
01520 #endif
01521 #endif
01522 #endif
01523 #undef USE_RUBY_ALLOC
01524 
01525     } else {
01526         /* string interface */
01527         CONST84 char **argv;
01528 #define USE_RUBY_ALLOC 0
01529 #if USE_RUBY_ALLOC
01530         argv = ALLOC_N(char *, 3); /* XXXXXXXXXX */
01531 #else /* not USE_RUBY_ALLOC */
01532         argv = RbTk_ALLOC_N(CONST84 char *, 3);
01533 #if 0 /* use Tcl_Preserve/Release */
01534         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
01535 #endif
01536 #endif
01537         argv[0] = (char *)"exit";
01538         /* argv[1] = Tcl_GetString(state_obj); */
01539         argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL);
01540         argv[2] = (char *)NULL;
01541 
01542         ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv);
01543 
01544 #if USE_RUBY_ALLOC
01545         xfree(argv);
01546 #else /* not USE_RUBY_ALLOC */
01547 #if 0 /* use Tcl_EventuallyFree */
01548         Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
01549 #else
01550 #if 0 /* use Tcl_Preserve/Release */
01551         Tcl_Release((ClientData)argv); /* XXXXXXXX */
01552 #else
01553         /* free(argv); */
01554         ckfree((char*)argv);
01555 #endif
01556 #endif
01557 #endif
01558 #undef USE_RUBY_ALLOC
01559     }
01560 
01561     Tcl_DecrRefCount(state_obj);
01562 
01563 #else /* TCL_MAJOR_VERSION < 8 */
01564     {
01565         /* string interface */
01566         char **argv;
01567 #define USE_RUBY_ALLOC 0
01568 #if USE_RUBY_ALLOC
01569         argv = (char **)ALLOC_N(char *, 3);
01570 #else /* not USE_RUBY_ALLOC */
01571         argv = RbTk_ALLOC_N(char *, 3);
01572 #if 0 /* use Tcl_Preserve/Release */
01573         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
01574 #endif
01575 #endif
01576         argv[0] = "exit";
01577         argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10));
01578         argv[2] = (char *)NULL;
01579 
01580         ptr->return_value = (*(info->proc))(info->clientData, ptr->ip,
01581                                             2, argv);
01582 
01583 #if USE_RUBY_ALLOC
01584         xfree(argv);
01585 #else /* not USE_RUBY_ALLOC */
01586 #if 0 /* use Tcl_EventuallyFree */
01587         Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
01588 #else
01589 #if 0 /* use Tcl_Preserve/Release */
01590         Tcl_Release((ClientData)argv); /* XXXXXXXX */
01591 #else
01592         /* free(argv); */
01593         ckfree(argv);
01594 #endif
01595 #endif
01596 #endif
01597 #undef USE_RUBY_ALLOC
01598     }
01599 #endif
01600     DUMP1("complete original_exit");
01601 
01602     rb_thread_critical = thr_crit_bup;
01603 }
01604 
01605 /* Tk_ThreadTimer */
01606 static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL;
01607 
01608 /* timer callback */
01609 static void _timer_for_tcl _((ClientData));
01610 static void
01611 _timer_for_tcl(clientData)
01612     ClientData clientData;
01613 {
01614     int thr_crit_bup;
01615 
01616     /* struct invoke_queue *q, *tmp; */
01617     /* VALUE thread; */
01618 
01619     DUMP1("call _timer_for_tcl");
01620 
01621     thr_crit_bup = rb_thread_critical;
01622     rb_thread_critical = Qtrue;
01623 
01624     Tcl_DeleteTimerHandler(timer_token);
01625 
01626     run_timer_flag = 1;
01627 
01628     if (timer_tick > 0) {
01629         timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
01630                                              (ClientData)0);
01631     } else {
01632         timer_token = (Tcl_TimerToken)NULL;
01633     }
01634 
01635     rb_thread_critical = thr_crit_bup;
01636 
01637     /* rb_thread_schedule(); */
01638     /* tick_counter += event_loop_max; */
01639 }
01640 
01641 #ifdef RUBY_USE_NATIVE_THREAD
01642 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
01643 static int
01644 toggle_eventloop_window_mode_for_idle()
01645 {
01646   if (window_event_mode & TCL_IDLE_EVENTS) {
01647     /* idle -> event */
01648     window_event_mode |= TCL_WINDOW_EVENTS;
01649     window_event_mode &= ~TCL_IDLE_EVENTS;
01650     return 1;
01651   } else {
01652     /* event -> idle */
01653     window_event_mode |= TCL_IDLE_EVENTS;
01654     window_event_mode &= ~TCL_WINDOW_EVENTS;
01655     return 0;
01656   }
01657 }
01658 #endif
01659 #endif
01660 
01661 static VALUE
01662 set_eventloop_window_mode(self, mode)
01663     VALUE self;
01664     VALUE mode;
01665 {
01666     rb_secure(4);
01667 
01668     if (RTEST(mode)) {
01669       window_event_mode = ~0;
01670     } else {
01671       window_event_mode = ~TCL_WINDOW_EVENTS;
01672     }
01673 
01674     return mode;
01675 }
01676 
01677 static VALUE
01678 get_eventloop_window_mode(self)
01679     VALUE self;
01680 {
01681     if ( ~window_event_mode ) {
01682       return Qfalse;
01683     } else {
01684       return Qtrue;
01685     }
01686 }
01687 
01688 static VALUE
01689 set_eventloop_tick(self, tick)
01690     VALUE self;
01691     VALUE tick;
01692 {
01693     int ttick = NUM2INT(tick);
01694     int thr_crit_bup;
01695 
01696     rb_secure(4);
01697 
01698     if (ttick < 0) {
01699         rb_raise(rb_eArgError,
01700                  "timer-tick parameter must be 0 or positive number");
01701     }
01702 
01703     thr_crit_bup = rb_thread_critical;
01704     rb_thread_critical = Qtrue;
01705 
01706     /* delete old timer callback */
01707     Tcl_DeleteTimerHandler(timer_token);
01708 
01709     timer_tick = req_timer_tick = ttick;
01710     if (timer_tick > 0) {
01711         /* start timer callback */
01712         timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
01713                                              (ClientData)0);
01714     } else {
01715         timer_token = (Tcl_TimerToken)NULL;
01716     }
01717 
01718     rb_thread_critical = thr_crit_bup;
01719 
01720     return tick;
01721 }
01722 
01723 static VALUE
01724 get_eventloop_tick(self)
01725     VALUE self;
01726 {
01727     return INT2NUM(timer_tick);
01728 }
01729 
01730 static VALUE
01731 ip_set_eventloop_tick(self, tick)
01732     VALUE self;
01733     VALUE tick;
01734 {
01735     struct tcltkip *ptr = get_ip(self);
01736 
01737     /* ip is deleted? */
01738     if (deleted_ip(ptr)) {
01739         return get_eventloop_tick(self);
01740     }
01741 
01742     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01743         /* slave IP */
01744         return get_eventloop_tick(self);
01745     }
01746     return set_eventloop_tick(self, tick);
01747 }
01748 
01749 static VALUE
01750 ip_get_eventloop_tick(self)
01751     VALUE self;
01752 {
01753     return get_eventloop_tick(self);
01754 }
01755 
01756 static VALUE
01757 set_no_event_wait(self, wait)
01758     VALUE self;
01759     VALUE wait;
01760 {
01761     int t_wait = NUM2INT(wait);
01762 
01763     rb_secure(4);
01764 
01765     if (t_wait <= 0) {
01766         rb_raise(rb_eArgError,
01767                  "no_event_wait parameter must be positive number");
01768     }
01769 
01770     no_event_wait = t_wait;
01771 
01772     return wait;
01773 }
01774 
01775 static VALUE
01776 get_no_event_wait(self)
01777     VALUE self;
01778 {
01779     return INT2NUM(no_event_wait);
01780 }
01781 
01782 static VALUE
01783 ip_set_no_event_wait(self, wait)
01784     VALUE self;
01785     VALUE wait;
01786 {
01787     struct tcltkip *ptr = get_ip(self);
01788 
01789     /* ip is deleted? */
01790     if (deleted_ip(ptr)) {
01791         return get_no_event_wait(self);
01792     }
01793 
01794     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01795         /* slave IP */
01796         return get_no_event_wait(self);
01797     }
01798     return set_no_event_wait(self, wait);
01799 }
01800 
01801 static VALUE
01802 ip_get_no_event_wait(self)
01803     VALUE self;
01804 {
01805     return get_no_event_wait(self);
01806 }
01807 
01808 static VALUE
01809 set_eventloop_weight(self, loop_max, no_event)
01810     VALUE self;
01811     VALUE loop_max;
01812     VALUE no_event;
01813 {
01814     int lpmax = NUM2INT(loop_max);
01815     int no_ev = NUM2INT(no_event);
01816 
01817     rb_secure(4);
01818 
01819     if (lpmax <= 0 || no_ev <= 0) {
01820         rb_raise(rb_eArgError, "weight parameters must be positive numbers");
01821     }
01822 
01823     event_loop_max = lpmax;
01824     no_event_tick  = no_ev;
01825 
01826     return rb_ary_new3(2, loop_max, no_event);
01827 }
01828 
01829 static VALUE
01830 get_eventloop_weight(self)
01831     VALUE self;
01832 {
01833     return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick));
01834 }
01835 
01836 static VALUE
01837 ip_set_eventloop_weight(self, loop_max, no_event)
01838     VALUE self;
01839     VALUE loop_max;
01840     VALUE no_event;
01841 {
01842     struct tcltkip *ptr = get_ip(self);
01843 
01844     /* ip is deleted? */
01845     if (deleted_ip(ptr)) {
01846         return get_eventloop_weight(self);
01847     }
01848 
01849     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01850         /* slave IP */
01851         return get_eventloop_weight(self);
01852     }
01853     return set_eventloop_weight(self, loop_max, no_event);
01854 }
01855 
01856 static VALUE
01857 ip_get_eventloop_weight(self)
01858     VALUE self;
01859 {
01860     return get_eventloop_weight(self);
01861 }
01862 
01863 static VALUE
01864 set_max_block_time(self, time)
01865     VALUE self;
01866     VALUE time;
01867 {
01868     struct Tcl_Time tcl_time;
01869     VALUE divmod;
01870 
01871     switch(TYPE(time)) {
01872     case T_FIXNUM:
01873     case T_BIGNUM:
01874         /* time is micro-second value */
01875         divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000));
01876         tcl_time.sec  = NUM2LONG(RARRAY_PTR(divmod)[0]);
01877         tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]);
01878         break;
01879 
01880     case T_FLOAT:
01881         /* time is second value */
01882         divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
01883         tcl_time.sec  = NUM2LONG(RARRAY_PTR(divmod)[0]);
01884         tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000);
01885 
01886     default:
01887         {
01888             VALUE tmp = rb_funcall(time, ID_inspect, 0, 0);
01889             rb_raise(rb_eArgError, "invalid value for time: '%s'",
01890                      StringValuePtr(tmp));
01891         }
01892     }
01893 
01894     Tcl_SetMaxBlockTime(&tcl_time);
01895 
01896     return Qnil;
01897 }
01898 
01899 static VALUE
01900 lib_evloop_thread_p(self)
01901     VALUE self;
01902 {
01903     if (NIL_P(eventloop_thread)) {
01904         return Qnil;    /* no eventloop */
01905     } else if (rb_thread_current() == eventloop_thread) {
01906         return Qtrue;   /* is eventloop */
01907     } else {
01908         return Qfalse;  /* not eventloop */
01909     }
01910 }
01911 
01912 static VALUE
01913 lib_evloop_abort_on_exc(self)
01914     VALUE self;
01915 {
01916     if (event_loop_abort_on_exc > 0) {
01917         return Qtrue;
01918     } else if (event_loop_abort_on_exc == 0) {
01919         return Qfalse;
01920     } else {
01921         return Qnil;
01922     }
01923 }
01924 
01925 static VALUE
01926 ip_evloop_abort_on_exc(self)
01927     VALUE self;
01928 {
01929     return lib_evloop_abort_on_exc(self);
01930 }
01931 
01932 static VALUE
01933 lib_evloop_abort_on_exc_set(self, val)
01934     VALUE self, val;
01935 {
01936     rb_secure(4);
01937     if (RTEST(val)) {
01938         event_loop_abort_on_exc =  1;
01939     } else if (NIL_P(val)) {
01940         event_loop_abort_on_exc = -1;
01941     } else {
01942         event_loop_abort_on_exc =  0;
01943     }
01944     return lib_evloop_abort_on_exc(self);
01945 }
01946 
01947 static VALUE
01948 ip_evloop_abort_on_exc_set(self, val)
01949     VALUE self, val;
01950 {
01951     struct tcltkip *ptr = get_ip(self);
01952 
01953     rb_secure(4);
01954 
01955     /* ip is deleted? */
01956     if (deleted_ip(ptr)) {
01957         return lib_evloop_abort_on_exc(self);
01958     }
01959 
01960     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01961         /* slave IP */
01962         return lib_evloop_abort_on_exc(self);
01963     }
01964     return lib_evloop_abort_on_exc_set(self, val);
01965 }
01966 
01967 static VALUE
01968 lib_num_of_mainwindows_core(self, argc, argv)
01969     VALUE self;
01970     int   argc;   /* dummy */
01971     VALUE *argv;  /* dummy */
01972 {
01973     if (tk_stubs_init_p()) {
01974         return INT2FIX(Tk_GetNumMainWindows());
01975     } else {
01976         return INT2FIX(0);
01977     }
01978 }
01979 
01980 static VALUE
01981 lib_num_of_mainwindows(self)
01982     VALUE self;
01983 {
01984 #ifdef RUBY_USE_NATIVE_THREAD  /* Ruby 1.9+ !!! */
01985     return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self);
01986 #else
01987     return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL);
01988 #endif
01989 }
01990 
01991 void
01992 rbtk_EventSetupProc(ClientData clientData, int flag)
01993 {
01994     Tcl_Time tcl_time;
01995     tcl_time.sec  = 0;
01996     tcl_time.usec = 1000L * (long)no_event_tick;
01997     Tcl_SetMaxBlockTime(&tcl_time);
01998 }
01999 
02000 void
02001 rbtk_EventCheckProc(ClientData clientData, int flag)
02002 {
02003     rb_thread_schedule();
02004 }
02005 
02006 
02007 #ifdef RUBY_USE_NATIVE_THREAD  /* Ruby 1.9+ !!! */
02008 static VALUE
02009 #ifdef HAVE_PROTOTYPES
02010 call_DoOneEvent_core(VALUE flag_val)
02011 #else
02012 call_DoOneEvent_core(flag_val)
02013     VALUE flag_val;
02014 #endif
02015 {
02016     int flag;
02017 
02018     flag = FIX2INT(flag_val);
02019     if (Tcl_DoOneEvent(flag)) {
02020         return Qtrue;
02021     } else {
02022         return Qfalse;
02023     }
02024 }
02025 
02026 static VALUE
02027 #ifdef HAVE_PROTOTYPES
02028 call_DoOneEvent(VALUE flag_val)
02029 #else
02030 call_DoOneEvent(flag_val)
02031     VALUE flag_val;
02032 #endif
02033 {
02034   return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val);
02035 }
02036 
02037 #else  /* Ruby 1.8- */
02038 static VALUE
02039 #ifdef HAVE_PROTOTYPES
02040 call_DoOneEvent(VALUE flag_val)
02041 #else
02042 call_DoOneEvent(flag_val)
02043     VALUE flag_val;
02044 #endif
02045 {
02046     int flag;
02047 
02048     flag = FIX2INT(flag_val);
02049     if (Tcl_DoOneEvent(flag)) {
02050         return Qtrue;
02051     } else {
02052         return Qfalse;
02053     }
02054 }
02055 #endif
02056 
02057 
02058 #if 0
02059 static VALUE
02060 #ifdef HAVE_PROTOTYPES
02061 eventloop_sleep(VALUE dummy)
02062 #else
02063 eventloop_sleep(dummy)
02064     VALUE dummy;
02065 #endif
02066 {
02067     struct timeval t;
02068 
02069     if (no_event_wait <= 0) {
02070       return Qnil;
02071     }
02072 
02073     t.tv_sec = 0;
02074     t.tv_usec = (int)(no_event_wait*1000.0);
02075 
02076 #ifdef HAVE_NATIVETHREAD
02077 #ifndef RUBY_USE_NATIVE_THREAD
02078     if (!ruby_native_thread_p()) {
02079         rb_bug("cross-thread violation on eventloop_sleep()");
02080     }
02081 #endif
02082 #endif
02083 
02084     DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current());
02085     rb_thread_wait_for(t);
02086     DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current());
02087 
02088 #ifdef HAVE_NATIVETHREAD
02089 #ifndef RUBY_USE_NATIVE_THREAD
02090     if (!ruby_native_thread_p()) {
02091         rb_bug("cross-thread violation on eventloop_sleep()");
02092     }
02093 #endif
02094 #endif
02095 
02096     return Qnil;
02097 }
02098 #endif
02099 
02100 #define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0
02101 
02102 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02103 static int
02104 get_thread_alone_check_flag()
02105 {
02106 #ifdef RUBY_USE_NATIVE_THREAD
02107   return 0;
02108 #else
02109   set_tcltk_version();
02110 
02111   if (tcltk_version.major < 8) {
02112     /* Tcl/Tk 7.x */
02113     return 1;
02114   } else if (tcltk_version.major == 8) {
02115     if (tcltk_version.minor < 5) {
02116       /* Tcl/Tk 8.0 - 8.4 */
02117       return 1;
02118     } else if (tcltk_version.minor == 5) {
02119       if (tcltk_version.type < TCL_FINAL_RELEASE) {
02120         /* Tcl/Tk 8.5a? - 8.5b? */
02121         return 1;
02122       } else {
02123         /* Tcl/Tk 8.5.x */
02124         return 0;
02125       }
02126     } else {
02127       /* Tcl/Tk 8.6 - 8.9 ?? */
02128       return 0;
02129     }
02130   } else {
02131     /* Tcl/Tk 9+ ?? */
02132     return 0;
02133   }
02134 #endif
02135 }
02136 #endif
02137 
02138 #define TRAP_CHECK() do { \
02139     if (trap_check(check_var) == 0) return 0; \
02140 } while (0)
02141 
02142 static int
02143 trap_check(int *check_var)
02144 {
02145     DUMP1("trap check");
02146 
02147 #ifdef RUBY_VM
02148     if (rb_thread_check_trap_pending()) {
02149         if (check_var != (int*)NULL) {
02150             /* wait command */
02151             return 0;
02152         }
02153         else {
02154             rb_thread_check_ints();
02155         }
02156     }
02157 #else
02158     if (rb_trap_pending) {
02159       run_timer_flag = 0;
02160       if (rb_prohibit_interrupt || check_var != (int*)NULL) {
02161         /* pending or on wait command */
02162         return 0;
02163       } else {
02164         rb_trap_exec();
02165       }
02166     }
02167 #endif
02168 
02169     return 1;
02170 }
02171 
02172 static int
02173 check_eventloop_interp()
02174 {
02175   DUMP1("check eventloop_interp");
02176   if (eventloop_interp != (Tcl_Interp*)NULL
02177       && Tcl_InterpDeleted(eventloop_interp)) {
02178     DUMP2("eventloop_interp(%p) was deleted", eventloop_interp);
02179     return 1;
02180   }
02181 
02182   return 0;
02183 }
02184 
02185 static int
02186 lib_eventloop_core(check_root, update_flag, check_var, interp)
02187     int check_root;
02188     int update_flag;
02189     int *check_var;
02190     Tcl_Interp *interp;
02191 {
02192     volatile VALUE current = eventloop_thread;
02193     int found_event = 1;
02194     int event_flag;
02195     struct timeval t;
02196     int thr_crit_bup;
02197     int status;
02198     int depth = rbtk_eventloop_depth;
02199 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02200     int thread_alone_check_flag = 1;
02201 #endif
02202 
02203     if (update_flag) DUMP1("update loop start!!");
02204 
02205     t.tv_sec = 0;
02206     t.tv_usec = 1000 * no_event_wait;
02207 
02208     Tcl_DeleteTimerHandler(timer_token);
02209     run_timer_flag = 0;
02210     if (timer_tick > 0) {
02211         thr_crit_bup = rb_thread_critical;
02212         rb_thread_critical = Qtrue;
02213         timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
02214                                              (ClientData)0);
02215         rb_thread_critical = thr_crit_bup;
02216     } else {
02217         timer_token = (Tcl_TimerToken)NULL;
02218     }
02219 
02220 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02221     /* version check */
02222     thread_alone_check_flag = get_thread_alone_check_flag();
02223 #endif
02224 
02225     for(;;) {
02226         if (check_eventloop_interp()) return 0;
02227 
02228 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02229         if (thread_alone_check_flag && rb_thread_alone()) {
02230 #else
02231         if (rb_thread_alone()) {
02232 #endif
02233             DUMP1("no other thread");
02234             event_loop_wait_event = 0;
02235 
02236             if (update_flag) {
02237                 event_flag = update_flag;
02238                 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */
02239             } else {
02240                 event_flag = TCL_ALL_EVENTS;
02241                 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */
02242             }
02243 
02244             if (timer_tick == 0 && update_flag == 0) {
02245                 timer_tick = NO_THREAD_INTERRUPT_TIME;
02246                 timer_token = Tcl_CreateTimerHandler(timer_tick,
02247                                                      _timer_for_tcl,
02248                                                      (ClientData)0);
02249             }
02250 
02251             if (check_var != (int *)NULL) {
02252                 if (*check_var || !found_event) {
02253                     return found_event;
02254                 }
02255                 if (interp != (Tcl_Interp*)NULL
02256                     && Tcl_InterpDeleted(interp)) {
02257                     /* IP for check_var is deleted */
02258                     return 0;
02259                 }
02260             }
02261 
02262             /* found_event = Tcl_DoOneEvent(event_flag); */
02263             found_event = RTEST(rb_protect(call_DoOneEvent,
02264                                            INT2FIX(event_flag), &status));
02265             if (status) {
02266                 switch (status) {
02267                 case TAG_RAISE:
02268                     if (NIL_P(rb_errinfo())) {
02269                         rbtk_pending_exception
02270                             = rb_exc_new2(rb_eException, "unknown exception");
02271                     } else {
02272                         rbtk_pending_exception = rb_errinfo();
02273 
02274                         if (!NIL_P(rbtk_pending_exception)) {
02275                             if (rbtk_eventloop_depth == 0) {
02276                                 VALUE exc = rbtk_pending_exception;
02277                                 rbtk_pending_exception = Qnil;
02278                                 rb_exc_raise(exc);
02279                             } else {
02280                                 return 0;
02281                             }
02282                         }
02283                     }
02284                     break;
02285 
02286                 case TAG_FATAL:
02287                     if (NIL_P(rb_errinfo())) {
02288                         rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
02289                     } else {
02290                         rb_exc_raise(rb_errinfo());
02291                     }
02292                 }
02293             }
02294 
02295             if (depth != rbtk_eventloop_depth) {
02296                 DUMP2("DoOneEvent(1) abnormal exit!! %d",
02297                       rbtk_eventloop_depth);
02298             }
02299 
02300             if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) {
02301                 DUMP1("exception on wait");
02302                 return 0;
02303             }
02304 
02305             if (pending_exception_check0()) {
02306                 /* pending -> upper level */
02307                 return 0;
02308             }
02309 
02310             if (update_flag != 0) {
02311               if (found_event) {
02312                 DUMP1("next update loop");
02313                 continue;
02314               } else {
02315                 DUMP1("update complete");
02316                 return 0;
02317               }
02318             }
02319 
02320             TRAP_CHECK();
02321             if (check_eventloop_interp()) return 0;
02322 
02323             DUMP1("check Root Widget");
02324             if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
02325                 run_timer_flag = 0;
02326                 TRAP_CHECK();
02327                 return 1;
02328             }
02329 
02330             if (loop_counter++ > 30000) {
02331                 /* fprintf(stderr, "loop_counter > 30000\n"); */
02332                 loop_counter = 0;
02333             }
02334 
02335         } else {
02336             int tick_counter;
02337 
02338             DUMP1("there are other threads");
02339             event_loop_wait_event = 1;
02340 
02341             found_event = 1;
02342 
02343             if (update_flag) {
02344                 event_flag = update_flag; /* for safety */
02345                 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */
02346             } else {
02347                 event_flag = TCL_ALL_EVENTS;
02348                 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */
02349             }
02350 
02351             timer_tick = req_timer_tick;
02352             tick_counter = 0;
02353             while(tick_counter < event_loop_max) {
02354                 if (check_var != (int *)NULL) {
02355                     if (*check_var || !found_event) {
02356                         return found_event;
02357                     }
02358                     if (interp != (Tcl_Interp*)NULL
02359                         && Tcl_InterpDeleted(interp)) {
02360                         /* IP for check_var is deleted */
02361                         return 0;
02362                     }
02363                 }
02364 
02365                 if (NIL_P(eventloop_thread) || current == eventloop_thread) {
02366                     int st;
02367                     int status;
02368 
02369 #ifdef RUBY_USE_NATIVE_THREAD
02370                     if (update_flag) {
02371                       st = RTEST(rb_protect(call_DoOneEvent,
02372                                             INT2FIX(event_flag), &status));
02373                     } else {
02374                       st = RTEST(rb_protect(call_DoOneEvent,
02375                                             INT2FIX(event_flag & window_event_mode),
02376                                             &status));
02377 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
02378                       if (!st) {
02379                         if (toggle_eventloop_window_mode_for_idle()) {
02380                           /* idle-mode -> event-mode*/
02381                           tick_counter = event_loop_max;
02382                         } else {
02383                           /* event-mode -> idle-mode */
02384                           tick_counter = 0;
02385                         }
02386                       }
02387 #endif
02388                     }
02389 #else
02390                     /* st = Tcl_DoOneEvent(event_flag); */
02391                     st = RTEST(rb_protect(call_DoOneEvent,
02392                                           INT2FIX(event_flag), &status));
02393 #endif
02394 
02395 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
02396                     if (have_rb_thread_waiting_for_value) {
02397                       have_rb_thread_waiting_for_value = 0;
02398                       rb_thread_schedule();
02399                     }
02400 #endif
02401 
02402                     if (status) {
02403                         switch (status) {
02404                         case TAG_RAISE:
02405                             if (NIL_P(rb_errinfo())) {
02406                                 rbtk_pending_exception
02407                                     = rb_exc_new2(rb_eException,
02408                                                   "unknown exception");
02409                             } else {
02410                                 rbtk_pending_exception = rb_errinfo();
02411 
02412                                 if (!NIL_P(rbtk_pending_exception)) {
02413                                     if (rbtk_eventloop_depth == 0) {
02414                                         VALUE exc = rbtk_pending_exception;
02415                                         rbtk_pending_exception = Qnil;
02416                                         rb_exc_raise(exc);
02417                                     } else {
02418                                         return 0;
02419                                     }
02420                                 }
02421                             }
02422                             break;
02423 
02424                         case TAG_FATAL:
02425                             if (NIL_P(rb_errinfo())) {
02426                                 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
02427                             } else {
02428                                 rb_exc_raise(rb_errinfo());
02429                             }
02430                         }
02431                     }
02432 
02433                     if (depth != rbtk_eventloop_depth) {
02434                         DUMP2("DoOneEvent(2) abnormal exit!! %d",
02435                               rbtk_eventloop_depth);
02436                         return 0;
02437                     }
02438 
02439                     TRAP_CHECK();
02440 
02441                     if (check_var != (int*)NULL
02442                         && !NIL_P(rbtk_pending_exception)) {
02443                         DUMP1("exception on wait");
02444                         return 0;
02445                     }
02446 
02447                     if (pending_exception_check0()) {
02448                         /* pending -> upper level */
02449                         return 0;
02450                     }
02451 
02452                     if (st) {
02453                         tick_counter++;
02454                     } else {
02455                         if (update_flag != 0) {
02456                             DUMP1("update complete");
02457                             return 0;
02458                         }
02459 
02460                         tick_counter += no_event_tick;
02461 
02462 #if 0
02463                         /* rb_thread_wait_for(t); */
02464                         rb_protect(eventloop_sleep, Qnil, &status);
02465 
02466                         if (status) {
02467                             switch (status) {
02468                             case TAG_RAISE:
02469                                 if (NIL_P(rb_errinfo())) {
02470                                     rbtk_pending_exception
02471                                         = rb_exc_new2(rb_eException,
02472                                                       "unknown exception");
02473                                 } else {
02474                                     rbtk_pending_exception = rb_errinfo();
02475 
02476                                     if (!NIL_P(rbtk_pending_exception)) {
02477                                         if (rbtk_eventloop_depth == 0) {
02478                                             VALUE exc = rbtk_pending_exception;
02479                                             rbtk_pending_exception = Qnil;
02480                                             rb_exc_raise(exc);
02481                                         } else {
02482                                             return 0;
02483                                         }
02484                                     }
02485                                 }
02486                                 break;
02487 
02488                             case TAG_FATAL:
02489                                 if (NIL_P(rb_errinfo())) {
02490                                     rb_exc_raise(rb_exc_new2(rb_eFatal,
02491                                                              "FATAL"));
02492                                 } else {
02493                                     rb_exc_raise(rb_errinfo());
02494                                 }
02495                             }
02496                         }
02497 #endif
02498                     }
02499 
02500                 } else {
02501                     DUMP2("sleep eventloop %lx", current);
02502                     DUMP2("eventloop thread is %lx", eventloop_thread);
02503                     /* rb_thread_stop(); */
02504                     rb_thread_sleep_forever();
02505                 }
02506 
02507                 if (!NIL_P(watchdog_thread) && eventloop_thread != current) {
02508                     return 1;
02509                 }
02510 
02511                 TRAP_CHECK();
02512                 if (check_eventloop_interp()) return 0;
02513 
02514                 DUMP1("check Root Widget");
02515                 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
02516                     run_timer_flag = 0;
02517                     TRAP_CHECK();
02518                     return 1;
02519                 }
02520 
02521                 if (loop_counter++ > 30000) {
02522                     /* fprintf(stderr, "loop_counter > 30000\n"); */
02523                     loop_counter = 0;
02524                 }
02525 
02526                 if (run_timer_flag) {
02527                     /*
02528                     DUMP1("timer interrupt");
02529                     run_timer_flag = 0;
02530                     */
02531                     break; /* switch to other thread */
02532                 }
02533             }
02534 
02535             DUMP1("thread scheduling");
02536             rb_thread_schedule();
02537         }
02538 
02539         DUMP1("check interrupts");
02540 #if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM)
02541         if (update_flag == 0) rb_thread_check_ints();
02542 #else
02543         if (update_flag == 0) CHECK_INTS;
02544 #endif
02545 
02546     }
02547     return 1;
02548 }
02549 
02550 
02551 struct evloop_params {
02552     int check_root;
02553     int update_flag;
02554     int *check_var;
02555     Tcl_Interp *interp;
02556     int thr_crit_bup;
02557 };
02558 
02559 VALUE
02560 lib_eventloop_main_core(args)
02561     VALUE args;
02562 {
02563     struct evloop_params *params = (struct evloop_params *)args;
02564 
02565     check_rootwidget_flag = params->check_root;
02566 
02567     Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
02568 
02569     if (lib_eventloop_core(params->check_root,
02570                            params->update_flag,
02571                            params->check_var,
02572                            params->interp)) {
02573         return Qtrue;
02574     } else {
02575         return Qfalse;
02576     }
02577 }
02578 
02579 VALUE
02580 lib_eventloop_main(args)
02581     VALUE args;
02582 {
02583     return lib_eventloop_main_core(args);
02584 
02585 #if 0
02586     volatile VALUE ret;
02587     int status = 0;
02588 
02589     ret = rb_protect(lib_eventloop_main_core, args, &status);
02590 
02591     switch (status) {
02592     case TAG_RAISE:
02593         if (NIL_P(rb_errinfo())) {
02594             rbtk_pending_exception
02595                 = rb_exc_new2(rb_eException, "unknown exception");
02596         } else {
02597             rbtk_pending_exception = rb_errinfo();
02598         }
02599         return Qnil;
02600 
02601     case TAG_FATAL:
02602         if (NIL_P(rb_errinfo())) {
02603             rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
02604         } else {
02605             rbtk_pending_exception = rb_errinfo();
02606         }
02607         return Qnil;
02608     }
02609 
02610     return ret;
02611 #endif
02612 }
02613 
02614 VALUE
02615 lib_eventloop_ensure(args)
02616     VALUE args;
02617 {
02618     struct evloop_params *ptr = (struct evloop_params *)args;
02619     volatile VALUE current_evloop = rb_thread_current();
02620 
02621     Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
02622 
02623     DUMP2("eventloop_ensure: current-thread : %lx", current_evloop);
02624     DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread);
02625     if (eventloop_thread != current_evloop) {
02626         DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop);
02627 
02628         rb_thread_critical = ptr->thr_crit_bup;
02629 
02630         xfree(ptr);
02631         /* ckfree((char*)ptr); */
02632 
02633         return Qnil;
02634     }
02635 
02636     while((eventloop_thread = rb_ary_pop(eventloop_stack))) {
02637         DUMP2("eventloop-ensure: new eventloop-thread -> %lx",
02638               eventloop_thread);
02639 
02640         if (eventloop_thread == current_evloop) {
02641             rbtk_eventloop_depth--;
02642             DUMP2("eventloop %lx : back from recursive call", current_evloop);
02643             break;
02644         }
02645 
02646         if (NIL_P(eventloop_thread)) {
02647           Tcl_DeleteTimerHandler(timer_token);
02648           timer_token = (Tcl_TimerToken)NULL;
02649 
02650           break;
02651         }
02652 
02653 #ifdef RUBY_VM
02654         if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) {
02655 #else
02656         if (RTEST(rb_thread_alive_p(eventloop_thread))) {
02657 #endif
02658             DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread);
02659             rb_thread_wakeup(eventloop_thread);
02660 
02661             break;
02662         }
02663     }
02664 
02665 #ifdef RUBY_USE_NATIVE_THREAD
02666     if (NIL_P(eventloop_thread)) {
02667         tk_eventloop_thread_id = (Tcl_ThreadId) 0;
02668     }
02669 #endif
02670 
02671     rb_thread_critical = ptr->thr_crit_bup;
02672 
02673     xfree(ptr);
02674     /* ckfree((char*)ptr);*/
02675 
02676     DUMP2("finish current eventloop %lx", current_evloop);
02677     return Qnil;
02678 }
02679 
02680 static VALUE
02681 lib_eventloop_launcher(check_root, update_flag, check_var, interp)
02682     int check_root;
02683     int update_flag;
02684     int *check_var;
02685     Tcl_Interp *interp;
02686 {
02687     volatile VALUE parent_evloop = eventloop_thread;
02688     struct evloop_params *args = ALLOC(struct evloop_params);
02689     /* struct evloop_params *args = RbTk_ALLOC_N(struct evloop_params, 1); */
02690 
02691     tcl_stubs_check();
02692 
02693     eventloop_thread = rb_thread_current();
02694 #ifdef RUBY_USE_NATIVE_THREAD
02695     tk_eventloop_thread_id = Tcl_GetCurrentThread();
02696 #endif
02697 
02698     if (parent_evloop == eventloop_thread) {
02699         DUMP2("eventloop: recursive call on %lx", parent_evloop);
02700         rbtk_eventloop_depth++;
02701     }
02702 
02703     if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) {
02704         DUMP2("wait for stop of parent_evloop %lx", parent_evloop);
02705         while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) {
02706             DUMP2("parent_evloop %lx doesn't stop", parent_evloop);
02707             rb_thread_run(parent_evloop);
02708         }
02709         DUMP1("succeed to stop parent");
02710     }
02711 
02712     rb_ary_push(eventloop_stack, parent_evloop);
02713 
02714     DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n",
02715                 parent_evloop, eventloop_thread);
02716 
02717     args->check_root   = check_root;
02718     args->update_flag  = update_flag;
02719     args->check_var    = check_var;
02720     args->interp       = interp;
02721     args->thr_crit_bup = rb_thread_critical;
02722 
02723     rb_thread_critical = Qfalse;
02724 
02725 #if 0
02726     return rb_ensure(lib_eventloop_main, (VALUE)args,
02727                      lib_eventloop_ensure, (VALUE)args);
02728 #endif
02729     return rb_ensure(lib_eventloop_main_core, (VALUE)args,
02730                      lib_eventloop_ensure, (VALUE)args);
02731 }
02732 
02733 /* execute Tk_MainLoop */
02734 static VALUE
02735 lib_mainloop(argc, argv, self)
02736     int   argc;
02737     VALUE *argv;
02738     VALUE self;
02739 {
02740     VALUE check_rootwidget;
02741 
02742     if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
02743         check_rootwidget = Qtrue;
02744     } else if (RTEST(check_rootwidget)) {
02745         check_rootwidget = Qtrue;
02746     } else {
02747         check_rootwidget = Qfalse;
02748     }
02749 
02750     return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
02751                                   (int*)NULL, (Tcl_Interp*)NULL);
02752 }
02753 
02754 static VALUE
02755 ip_mainloop(argc, argv, self)
02756     int   argc;
02757     VALUE *argv;
02758     VALUE self;
02759 {
02760     volatile VALUE ret;
02761     struct tcltkip *ptr = get_ip(self);
02762 
02763     /* ip is deleted? */
02764     if (deleted_ip(ptr)) {
02765         return Qnil;
02766     }
02767 
02768     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
02769         /* slave IP */
02770         return Qnil;
02771     }
02772 
02773     eventloop_interp = ptr->ip;
02774     ret = lib_mainloop(argc, argv, self);
02775     eventloop_interp = (Tcl_Interp*)NULL;
02776     return ret;
02777 }
02778 
02779 
02780 static VALUE
02781 watchdog_evloop_launcher(check_rootwidget)
02782     VALUE check_rootwidget;
02783 {
02784     return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
02785                                   (int*)NULL, (Tcl_Interp*)NULL);
02786 }
02787 
02788 #define EVLOOP_WAKEUP_CHANCE 3
02789 
02790 static VALUE
02791 lib_watchdog_core(check_rootwidget)
02792     VALUE check_rootwidget;
02793 {
02794     VALUE evloop;
02795     int   prev_val = -1;
02796     int   chance = 0;
02797     int   check = RTEST(check_rootwidget);
02798     struct timeval t0, t1;
02799 
02800     t0.tv_sec  = 0;
02801     t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0);
02802     t1.tv_sec  = 0;
02803     t1.tv_usec = (long)((WATCHDOG_INTERVAL)*1000.0);
02804 
02805     /* check other watchdog thread */
02806     if (!NIL_P(watchdog_thread)) {
02807         if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) {
02808             rb_funcall(watchdog_thread, ID_kill, 0);
02809         } else {
02810             return Qnil;
02811         }
02812     }
02813     watchdog_thread = rb_thread_current();
02814 
02815     /* watchdog start */
02816     do {
02817         if (NIL_P(eventloop_thread)
02818             || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) {
02819             /* start new eventloop thread */
02820             DUMP2("eventloop thread %lx is sleeping or dead",
02821                   eventloop_thread);
02822             evloop = rb_thread_create(watchdog_evloop_launcher,
02823                                       (void*)&check_rootwidget);
02824             DUMP2("create new eventloop thread %lx", evloop);
02825             loop_counter = -1;
02826             chance = 0;
02827             rb_thread_run(evloop);
02828         } else {
02829             prev_val = loop_counter;
02830             if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) {
02831                 ++chance;
02832             } else {
02833                 chance = 0;
02834             }
02835             if (event_loop_wait_event) {
02836                 rb_thread_wait_for(t0);
02837             } else {
02838                 rb_thread_wait_for(t1);
02839             }
02840             /* rb_thread_schedule(); */
02841         }
02842     } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0);
02843 
02844     return Qnil;
02845 }
02846 
02847 VALUE
02848 lib_watchdog_ensure(arg)
02849     VALUE arg;
02850 {
02851     eventloop_thread = Qnil; /* stop eventloops */
02852 #ifdef RUBY_USE_NATIVE_THREAD
02853     tk_eventloop_thread_id = (Tcl_ThreadId) 0;
02854 #endif
02855     return Qnil;
02856 }
02857 
02858 static VALUE
02859 lib_mainloop_watchdog(argc, argv, self)
02860     int   argc;
02861     VALUE *argv;
02862     VALUE self;
02863 {
02864     VALUE check_rootwidget;
02865 
02866 #ifdef RUBY_VM
02867     rb_raise(rb_eNotImpError,
02868              "eventloop_watchdog is not implemented on Ruby VM.");
02869 #endif
02870 
02871     if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
02872         check_rootwidget = Qtrue;
02873     } else if (RTEST(check_rootwidget)) {
02874         check_rootwidget = Qtrue;
02875     } else {
02876         check_rootwidget = Qfalse;
02877     }
02878 
02879     return rb_ensure(lib_watchdog_core, check_rootwidget,
02880                      lib_watchdog_ensure, Qnil);
02881 }
02882 
02883 static VALUE
02884 ip_mainloop_watchdog(argc, argv, self)
02885     int   argc;
02886     VALUE *argv;
02887     VALUE self;
02888 {
02889     struct tcltkip *ptr = get_ip(self);
02890 
02891     /* ip is deleted? */
02892     if (deleted_ip(ptr)) {
02893         return Qnil;
02894     }
02895 
02896     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
02897         /* slave IP */
02898         return Qnil;
02899     }
02900     return lib_mainloop_watchdog(argc, argv, self);
02901 }
02902 
02903 
02904 /* thread-safe(?) interaction between Ruby and Tk */
02905 struct thread_call_proc_arg {
02906     VALUE proc;
02907     int *done;
02908 };
02909 
02910 void
02911 _thread_call_proc_arg_mark(struct thread_call_proc_arg *q)
02912 {
02913     rb_gc_mark(q->proc);
02914 }
02915 
02916 static VALUE
02917 _thread_call_proc_core(arg)
02918     VALUE arg;
02919 {
02920     struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02921     return rb_funcall(q->proc, ID_call, 0);
02922 }
02923 
02924 static VALUE
02925 _thread_call_proc_ensure(arg)
02926     VALUE arg;
02927 {
02928     struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02929     *(q->done) = 1;
02930     return Qnil;
02931 }
02932 
02933 static VALUE
02934 _thread_call_proc(arg)
02935     VALUE arg;
02936 {
02937     struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02938 
02939     return rb_ensure(_thread_call_proc_core, (VALUE)q,
02940                      _thread_call_proc_ensure, (VALUE)q);
02941 }
02942 
02943 static VALUE
02944 #ifdef HAVE_PROTOTYPES
02945 _thread_call_proc_value(VALUE th)
02946 #else
02947 _thread_call_proc_value(th)
02948     VALUE th;
02949 #endif
02950 {
02951     return rb_funcall(th, ID_value, 0);
02952 }
02953 
02954 static VALUE
02955 lib_thread_callback(argc, argv, self)
02956     int argc;
02957     VALUE *argv;
02958     VALUE self;
02959 {
02960     struct thread_call_proc_arg *q;
02961     VALUE proc, th, ret;
02962     int status, foundEvent;
02963 
02964     if (rb_scan_args(argc, argv, "01", &proc) == 0) {
02965         proc = rb_block_proc();
02966     }
02967 
02968     q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg);
02969     /* q = RbTk_ALLOC_N(struct thread_call_proc_arg, 1); */
02970     q->proc = proc;
02971     q->done = (int*)ALLOC(int);
02972     /* q->done = RbTk_ALLOC_N(int, 1); */
02973     *(q->done) = 0;
02974 
02975     /* create call-proc thread */
02976     th = rb_thread_create(_thread_call_proc, (void*)q);
02977 
02978     rb_thread_schedule();
02979 
02980     /* start sub-eventloop */
02981     foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 0,
02982                                               q->done, (Tcl_Interp*)NULL));
02983 
02984 #ifdef RUBY_VM
02985     if (RTEST(rb_funcall(th, ID_alive_p, 0))) {
02986 #else
02987     if (RTEST(rb_thread_alive_p(th))) {
02988 #endif
02989         rb_funcall(th, ID_kill, 0);
02990         ret = Qnil;
02991     } else {
02992         ret = rb_protect(_thread_call_proc_value, th, &status);
02993     }
02994 
02995     xfree(q->done);
02996     xfree(q);
02997     /* ckfree((char*)q->done); */
02998     /* ckfree((char*)q); */
02999 
03000     if (NIL_P(rbtk_pending_exception)) {
03001         /* return rb_errinfo(); */
03002         if (status) {
03003             rb_exc_raise(rb_errinfo());
03004         }
03005     } else {
03006         VALUE exc = rbtk_pending_exception;
03007         rbtk_pending_exception = Qnil;
03008         /* return exc; */
03009         rb_exc_raise(exc);
03010     }
03011 
03012     return ret;
03013 }
03014 
03015 
03016 /* do_one_event */
03017 static VALUE
03018 lib_do_one_event_core(argc, argv, self, is_ip)
03019     int   argc;
03020     VALUE *argv;
03021     VALUE self;
03022     int   is_ip;
03023 {
03024     volatile VALUE vflags;
03025     int flags;
03026     int found_event;
03027 
03028     if (!NIL_P(eventloop_thread)) {
03029         rb_raise(rb_eRuntimeError, "eventloop is already running");
03030     }
03031 
03032     tcl_stubs_check();
03033 
03034     if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
03035         flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
03036     } else {
03037         Check_Type(vflags, T_FIXNUM);
03038         flags = FIX2INT(vflags);
03039     }
03040 
03041     if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) {
03042       flags |= TCL_DONT_WAIT;
03043     }
03044 
03045     if (is_ip) {
03046         /* check IP */
03047         struct tcltkip *ptr = get_ip(self);
03048 
03049         /* ip is deleted? */
03050         if (deleted_ip(ptr)) {
03051             return Qfalse;
03052         }
03053 
03054         if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
03055             /* slave IP */
03056             flags |= TCL_DONT_WAIT;
03057         }
03058     }
03059 
03060     /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
03061     found_event = Tcl_DoOneEvent(flags);
03062 
03063     if (pending_exception_check0()) {
03064         return Qfalse;
03065     }
03066 
03067     if (found_event) {
03068         return Qtrue;
03069     } else {
03070         return Qfalse;
03071     }
03072 }
03073 
03074 static VALUE
03075 lib_do_one_event(argc, argv, self)
03076     int   argc;
03077     VALUE *argv;
03078     VALUE self;
03079 {
03080     return lib_do_one_event_core(argc, argv, self, 0);
03081 }
03082 
03083 static VALUE
03084 ip_do_one_event(argc, argv, self)
03085     int   argc;
03086     VALUE *argv;
03087     VALUE self;
03088 {
03089     return lib_do_one_event_core(argc, argv, self, 0);
03090 }
03091 
03092 
03093 static void
03094 ip_set_exc_message(interp, exc)
03095     Tcl_Interp *interp;
03096     VALUE exc;
03097 {
03098     char *buf;
03099     Tcl_DString dstr;
03100     volatile VALUE msg;
03101     int thr_crit_bup;
03102 
03103 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
03104     volatile VALUE enc;
03105     Tcl_Encoding encoding;
03106 #endif
03107 
03108     thr_crit_bup = rb_thread_critical;
03109     rb_thread_critical = Qtrue;
03110 
03111     msg = rb_funcall(exc, ID_message, 0, 0);
03112     StringValue(msg);
03113 
03114 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
03115     enc = rb_attr_get(exc, ID_at_enc);
03116     if (NIL_P(enc)) {
03117         enc = rb_attr_get(msg, ID_at_enc);
03118     }
03119     if (NIL_P(enc)) {
03120         encoding = (Tcl_Encoding)NULL;
03121     } else if (TYPE(enc) == T_STRING) {
03122         /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
03123         encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
03124     } else {
03125         enc = rb_funcall(enc, ID_to_s, 0, 0);
03126         /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
03127         encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
03128     }
03129 
03130     /* to avoid a garbled error message dialog */
03131     /* buf = ALLOC_N(char, (RSTRING(msg)->len)+1);*/
03132     /* memcpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);*/
03133     /* buf[RSTRING(msg)->len] = 0; */
03134     buf = ALLOC_N(char, RSTRING_LENINT(msg)+1);
03135     /* buf = ckalloc(RSTRING_LENINT(msg)+1); */
03136     memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg));
03137     buf[RSTRING_LEN(msg)] = 0;
03138 
03139     Tcl_DStringInit(&dstr);
03140     Tcl_DStringFree(&dstr);
03141     Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(msg), &dstr);
03142 
03143     Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
03144     DUMP2("error message:%s", Tcl_DStringValue(&dstr));
03145     Tcl_DStringFree(&dstr);
03146     xfree(buf);
03147     /* ckfree(buf); */
03148 
03149 #else /* TCL_VERSION <= 8.0 */
03150     Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL);
03151 #endif
03152 
03153     rb_thread_critical = thr_crit_bup;
03154 }
03155 
03156 static VALUE
03157 TkStringValue(obj)
03158     VALUE obj;
03159 {
03160     switch(TYPE(obj)) {
03161     case T_STRING:
03162         return obj;
03163 
03164     case T_NIL:
03165         return rb_str_new2("");
03166 
03167     case T_TRUE:
03168         return rb_str_new2("1");
03169 
03170     case T_FALSE:
03171         return rb_str_new2("0");
03172 
03173     case T_ARRAY:
03174         return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
03175 
03176     default:
03177         if (rb_respond_to(obj, ID_to_s)) {
03178             return rb_funcall(obj, ID_to_s, 0, 0);
03179         }
03180     }
03181 
03182     return rb_funcall(obj, ID_inspect, 0, 0);
03183 }
03184 
03185 static int
03186 #ifdef HAVE_PROTOTYPES
03187 tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data)
03188 #else
03189 tcl_protect_core(interp, proc, data) /* should not raise exception */
03190     Tcl_Interp *interp;
03191     VALUE (*proc)();
03192     VALUE data;
03193 #endif
03194 {
03195     volatile VALUE ret, exc = Qnil;
03196     int status = 0;
03197     int thr_crit_bup = rb_thread_critical;
03198 
03199     Tcl_ResetResult(interp);
03200 
03201     rb_thread_critical = Qfalse;
03202     ret = rb_protect(proc, data, &status);
03203     rb_thread_critical = Qtrue;
03204     if (status) {
03205         char *buf;
03206         VALUE old_gc;
03207         volatile VALUE type, str;
03208 
03209         old_gc = rb_gc_disable();
03210 
03211         switch(status) {
03212         case TAG_RETURN:
03213             type = eTkCallbackReturn;
03214             goto error;
03215         case TAG_BREAK:
03216             type = eTkCallbackBreak;
03217             goto error;
03218         case TAG_NEXT:
03219             type = eTkCallbackContinue;
03220             goto error;
03221         error:
03222             str = rb_str_new2("LocalJumpError: ");
03223             rb_str_append(str, rb_obj_as_string(rb_errinfo()));
03224             exc = rb_exc_new3(type, str);
03225             break;
03226 
03227         case TAG_RETRY:
03228             if (NIL_P(rb_errinfo())) {
03229                 DUMP1("rb_protect: retry");
03230                 exc = rb_exc_new2(eTkCallbackRetry, "retry jump error");
03231             } else {
03232                 exc = rb_errinfo();
03233             }
03234             break;
03235 
03236         case TAG_REDO:
03237             if (NIL_P(rb_errinfo())) {
03238                 DUMP1("rb_protect: redo");
03239                 exc = rb_exc_new2(eTkCallbackRedo,  "redo jump error");
03240             } else {
03241                 exc = rb_errinfo();
03242             }
03243             break;
03244 
03245         case TAG_RAISE:
03246             if (NIL_P(rb_errinfo())) {
03247                 exc = rb_exc_new2(rb_eException, "unknown exception");
03248             } else {
03249                 exc = rb_errinfo();
03250             }
03251             break;
03252 
03253         case TAG_FATAL:
03254             if (NIL_P(rb_errinfo())) {
03255                 exc = rb_exc_new2(rb_eFatal, "FATAL");
03256             } else {
03257                 exc = rb_errinfo();
03258             }
03259             break;
03260 
03261         case TAG_THROW:
03262             if (NIL_P(rb_errinfo())) {
03263                 DUMP1("rb_protect: throw");
03264                 exc = rb_exc_new2(eTkCallbackThrow,  "throw jump error");
03265             } else {
03266                 exc = rb_errinfo();
03267             }
03268             break;
03269 
03270         default:
03271             buf = ALLOC_N(char, 256);
03272             /* buf = ckalloc(sizeof(char) * 256); */
03273             sprintf(buf, "unknown loncaljmp status %d", status);
03274             exc = rb_exc_new2(rb_eException, buf);
03275             xfree(buf);
03276             /* ckfree(buf); */
03277             break;
03278         }
03279 
03280         if (old_gc == Qfalse) rb_gc_enable();
03281 
03282         ret = Qnil;
03283     }
03284 
03285     rb_thread_critical = thr_crit_bup;
03286 
03287     Tcl_ResetResult(interp);
03288 
03289     /* status check */
03290     if (!NIL_P(exc)) {
03291         volatile VALUE eclass = rb_obj_class(exc);
03292         volatile VALUE backtrace;
03293 
03294         DUMP1("(failed)");
03295 
03296         thr_crit_bup = rb_thread_critical;
03297         rb_thread_critical = Qtrue;
03298 
03299         DUMP1("set backtrace");
03300         if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) {
03301             backtrace = rb_ary_join(backtrace, rb_str_new2("\n"));
03302             Tcl_AddErrorInfo(interp, StringValuePtr(backtrace));
03303         }
03304 
03305         rb_thread_critical = thr_crit_bup;
03306 
03307         ip_set_exc_message(interp, exc);
03308 
03309         if (eclass == eTkCallbackReturn)
03310             return TCL_RETURN;
03311 
03312         if (eclass == eTkCallbackBreak)
03313             return TCL_BREAK;
03314 
03315         if (eclass == eTkCallbackContinue)
03316             return TCL_CONTINUE;
03317 
03318         if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) {
03319             rbtk_pending_exception = exc;
03320             return TCL_RETURN;
03321         }
03322 
03323         if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) {
03324             rbtk_pending_exception = exc;
03325             return TCL_ERROR;
03326         }
03327 
03328         if (rb_obj_is_kind_of(exc, eLocalJumpError)) {
03329             VALUE reason = rb_ivar_get(exc, ID_at_reason);
03330 
03331             if (TYPE(reason) == T_SYMBOL) {
03332                 if (SYM2ID(reason) == ID_return)
03333                     return TCL_RETURN;
03334 
03335                 if (SYM2ID(reason) == ID_break)
03336                     return TCL_BREAK;
03337 
03338                 if (SYM2ID(reason) == ID_next)
03339                     return TCL_CONTINUE;
03340             }
03341         }
03342 
03343         return TCL_ERROR;
03344     }
03345 
03346     /* result must be string or nil */
03347     if (!NIL_P(ret)) {
03348         /* copy result to the tcl interpreter */
03349         thr_crit_bup = rb_thread_critical;
03350         rb_thread_critical = Qtrue;
03351 
03352         ret = TkStringValue(ret);
03353         DUMP1("Tcl_AppendResult");
03354         Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL);
03355 
03356         rb_thread_critical = thr_crit_bup;
03357     }
03358 
03359     DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret));
03360 
03361     return TCL_OK;
03362 }
03363 
03364 static int
03365 tcl_protect(interp, proc, data)
03366     Tcl_Interp *interp;
03367     VALUE (*proc)();
03368     VALUE data;
03369 {
03370     int code;
03371 
03372 #ifdef HAVE_NATIVETHREAD
03373 #ifndef RUBY_USE_NATIVE_THREAD
03374     if (!ruby_native_thread_p()) {
03375         rb_bug("cross-thread violation on tcl_protect()");
03376     }
03377 #endif
03378 #endif
03379 
03380 #ifdef RUBY_VM
03381     code = tcl_protect_core(interp, proc, data);
03382 #else
03383     do {
03384       int old_trapflag = rb_trap_immediate;
03385       rb_trap_immediate = 0;
03386       code = tcl_protect_core(interp, proc, data);
03387       rb_trap_immediate = old_trapflag;
03388     } while (0);
03389 #endif
03390 
03391     return code;
03392 }
03393 
03394 static int
03395 #if TCL_MAJOR_VERSION >= 8
03396 ip_ruby_eval(clientData, interp, argc, argv)
03397     ClientData clientData;
03398     Tcl_Interp *interp;
03399     int argc;
03400     Tcl_Obj *CONST argv[];
03401 #else /* TCL_MAJOR_VERSION < 8 */
03402 ip_ruby_eval(clientData, interp, argc, argv)
03403     ClientData clientData;
03404     Tcl_Interp *interp;
03405     int argc;
03406     char *argv[];
03407 #endif
03408 {
03409     char *arg;
03410     int thr_crit_bup;
03411     int code;
03412 
03413     if (interp == (Tcl_Interp*)NULL) {
03414         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03415                                              "IP is deleted");
03416         return TCL_ERROR;
03417     }
03418 
03419     /* ruby command has 1 arg. */
03420     if (argc != 2) {
03421 #if 0
03422         rb_raise(rb_eArgError,
03423                  "wrong number of arguments (%d for 1)", argc - 1);
03424 #else
03425         char buf[sizeof(int)*8 + 1];
03426         Tcl_ResetResult(interp);
03427         sprintf(buf, "%d", argc-1);
03428         Tcl_AppendResult(interp, "wrong number of arguments (",
03429                          buf, " for 1)", (char *)NULL);
03430         rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03431                                              Tcl_GetStringResult(interp));
03432         return TCL_ERROR;
03433 #endif
03434     }
03435 
03436     /* get C string from Tcl object */
03437 #if TCL_MAJOR_VERSION >= 8
03438     {
03439       char *str;
03440       int  len;
03441 
03442       thr_crit_bup = rb_thread_critical;
03443       rb_thread_critical = Qtrue;
03444 
03445       str = Tcl_GetStringFromObj(argv[1], &len);
03446       arg = ALLOC_N(char, len + 1);
03447       /* arg = ckalloc(sizeof(char) * (len + 1)); */
03448       memcpy(arg, str, len);
03449       arg[len] = 0;
03450 
03451       rb_thread_critical = thr_crit_bup;
03452 
03453     }
03454 #else /* TCL_MAJOR_VERSION < 8 */
03455     arg = argv[1];
03456 #endif
03457 
03458     /* evaluate the argument string by ruby */
03459     DUMP2("rb_eval_string(%s)", arg);
03460 
03461     code = tcl_protect(interp, rb_eval_string, (VALUE)arg);
03462 
03463 #if TCL_MAJOR_VERSION >= 8
03464     xfree(arg);
03465     /* ckfree(arg); */
03466 #endif
03467 
03468     return code;
03469 }
03470 
03471 
03472 /* Tcl command `ruby_cmd' */
03473 static VALUE
03474 ip_ruby_cmd_core(arg)
03475     struct cmd_body_arg *arg;
03476 {
03477     volatile VALUE ret;
03478     int thr_crit_bup;
03479 
03480     DUMP1("call ip_ruby_cmd_core");
03481     thr_crit_bup = rb_thread_critical;
03482     rb_thread_critical = Qfalse;
03483     ret = rb_apply(arg->receiver, arg->method, arg->args);
03484     DUMP2("rb_apply return:%lx", ret);
03485     rb_thread_critical = thr_crit_bup;
03486     DUMP1("finish ip_ruby_cmd_core");
03487 
03488     return ret;
03489 }
03490 
03491 #define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1
03492 
03493 static VALUE
03494 ip_ruby_cmd_receiver_const_get(name)
03495      char *name;
03496 {
03497   volatile VALUE klass = rb_cObject;
03498 #if 0
03499   char *head, *tail;
03500 #endif
03501   int state;
03502 
03503 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03504   klass = rb_eval_string_protect(name, &state);
03505   if (state) {
03506     return Qnil;
03507   } else {
03508     return klass;
03509   }
03510 #else
03511   return rb_const_get(klass, rb_intern(name));
03512 #endif
03513 
03514   /* TODO!!!!!! */
03515   /* support nest of classes/modules */
03516 
03517   /* return rb_eval_string(name); */
03518   /* return rb_eval_string_protect(name, &state); */
03519 
03520 #if 0 /* doesn't work!! (fail to autoload?) */
03521   /* duplicate */
03522   head = name = strdup(name);
03523 
03524   /* has '::' at head ? */
03525   if (*head == ':')  head += 2;
03526   tail = head;
03527 
03528   /* search */
03529   while(*tail) {
03530     if (*tail == ':') {
03531       *tail = '\0';
03532       klass = rb_const_get(klass, rb_intern(head));
03533       tail += 2;
03534       head = tail;
03535     } else {
03536       tail++;
03537     }
03538   }
03539 
03540   free(name);
03541   return rb_const_get(klass, rb_intern(head));
03542 #endif
03543 }
03544 
03545 static VALUE
03546 ip_ruby_cmd_receiver_get(str)
03547      char *str;
03548 {
03549   volatile VALUE receiver;
03550 #if !SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03551   int state;
03552 #endif
03553 
03554   if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
03555     /* class | module | constant */
03556 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03557     receiver = ip_ruby_cmd_receiver_const_get(str);
03558 #else
03559     receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state);
03560     if (state) return Qnil;
03561 #endif
03562   } else if (str[0] == '$') {
03563     /* global variable */
03564     receiver = rb_gv_get(str);
03565   } else {
03566     /* global variable omitted '$' */
03567     char *buf;
03568     size_t len;
03569 
03570     len = strlen(str);
03571     buf = ALLOC_N(char, len + 2);
03572     /* buf = ckalloc(sizeof(char) * (len + 2)); */
03573     buf[0] = '$';
03574     memcpy(buf + 1, str, len);
03575     buf[len + 1] = 0;
03576     receiver = rb_gv_get(buf);
03577     xfree(buf);
03578     /* ckfree(buf); */
03579   }
03580 
03581   return receiver;
03582 }
03583 
03584 /* ruby_cmd receiver method arg ... */
03585 static int
03586 #if TCL_MAJOR_VERSION >= 8
03587 ip_ruby_cmd(clientData, interp, argc, argv)
03588     ClientData clientData;
03589     Tcl_Interp *interp;
03590     int argc;
03591     Tcl_Obj *CONST argv[];
03592 #else /* TCL_MAJOR_VERSION < 8 */
03593 ip_ruby_cmd(clientData, interp, argc, argv)
03594     ClientData clientData;
03595     Tcl_Interp *interp;
03596     int argc;
03597     char *argv[];
03598 #endif
03599 {
03600     volatile VALUE receiver;
03601     volatile ID method;
03602     volatile VALUE args;
03603     char *str;
03604     int i;
03605     int  len;
03606     struct cmd_body_arg *arg;
03607     int thr_crit_bup;
03608     VALUE old_gc;
03609     int code;
03610 
03611     if (interp == (Tcl_Interp*)NULL) {
03612         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03613                                              "IP is deleted");
03614         return TCL_ERROR;
03615     }
03616 
03617     if (argc < 3) {
03618 #if 0
03619         rb_raise(rb_eArgError, "too few arguments");
03620 #else
03621         Tcl_ResetResult(interp);
03622         Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
03623         rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03624                                              Tcl_GetStringResult(interp));
03625         return TCL_ERROR;
03626 #endif
03627     }
03628 
03629     /* get arguments from Tcl objects */
03630     thr_crit_bup = rb_thread_critical;
03631     rb_thread_critical = Qtrue;
03632     old_gc = rb_gc_disable();
03633 
03634     /* get receiver */
03635 #if TCL_MAJOR_VERSION >= 8
03636     str = Tcl_GetStringFromObj(argv[1], &len);
03637 #else /* TCL_MAJOR_VERSION < 8 */
03638     str = argv[1];
03639 #endif
03640     DUMP2("receiver:%s",str);
03641     /* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */
03642     receiver = ip_ruby_cmd_receiver_get(str);
03643     if (NIL_P(receiver)) {
03644 #if 0
03645         rb_raise(rb_eArgError,
03646                  "unknown class/module/global-variable '%s'", str);
03647 #else
03648         Tcl_ResetResult(interp);
03649         Tcl_AppendResult(interp, "unknown class/module/global-variable '",
03650                          str, "'", (char *)NULL);
03651         rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03652                                              Tcl_GetStringResult(interp));
03653         if (old_gc == Qfalse) rb_gc_enable();
03654         return TCL_ERROR;
03655 #endif
03656     }
03657 
03658     /* get metrhod */
03659 #if TCL_MAJOR_VERSION >= 8
03660     str = Tcl_GetStringFromObj(argv[2], &len);
03661 #else /* TCL_MAJOR_VERSION < 8 */
03662     str = argv[2];
03663 #endif
03664     method = rb_intern(str);
03665 
03666     /* get args */
03667     args = rb_ary_new2(argc - 2);
03668     for(i = 3; i < argc; i++) {
03669         VALUE s;
03670 #if TCL_MAJOR_VERSION >= 8
03671         str = Tcl_GetStringFromObj(argv[i], &len);
03672         s = rb_tainted_str_new(str, len);
03673 #else /* TCL_MAJOR_VERSION < 8 */
03674         str = argv[i];
03675         s = rb_tainted_str_new2(str);
03676 #endif
03677         DUMP2("arg:%s",str);
03678 #ifndef HAVE_STRUCT_RARRAY_LEN
03679         rb_ary_push(args, s);
03680 #else
03681         RARRAY(args)->ptr[RARRAY(args)->len++] = s;
03682 #endif
03683     }
03684 
03685     if (old_gc == Qfalse) rb_gc_enable();
03686     rb_thread_critical = thr_crit_bup;
03687 
03688     /* allocate */
03689     arg = ALLOC(struct cmd_body_arg);
03690     /* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */
03691 
03692     arg->receiver = receiver;
03693     arg->method = method;
03694     arg->args = args;
03695 
03696     /* evaluate the argument string by ruby */
03697     code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg);
03698 
03699     xfree(arg);
03700     /* ckfree((char*)arg); */
03701 
03702     return code;
03703 }
03704 
03705 
03706 /*****************************/
03707 /* relpace of 'exit' command */
03708 /*****************************/
03709 static int
03710 #if TCL_MAJOR_VERSION >= 8
03711 #ifdef HAVE_PROTOTYPES
03712 ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp,
03713                     int argc, Tcl_Obj *CONST argv[])
03714 #else
03715 ip_InterpExitObjCmd(clientData, interp, argc, argv)
03716     ClientData clientData;
03717     Tcl_Interp *interp;
03718     int argc;
03719     Tcl_Obj *CONST argv[];
03720 #endif
03721 #else /* TCL_MAJOR_VERSION < 8 */
03722 #ifdef HAVE_PROTOTYPES
03723 ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp,
03724                      int argc, char *argv[])
03725 #else
03726 ip_InterpExitCommand(clientData, interp, argc, argv)
03727     ClientData clientData;
03728     Tcl_Interp *interp;
03729     int argc;
03730     char *argv[];
03731 #endif
03732 #endif
03733 {
03734     DUMP1("start ip_InterpExitCommand");
03735     if (interp != (Tcl_Interp*)NULL
03736         && !Tcl_InterpDeleted(interp)
03737 #if TCL_NAMESPACE_DEBUG
03738         && !ip_null_namespace(interp)
03739 #endif
03740         ) {
03741         Tcl_ResetResult(interp);
03742         /* Tcl_Preserve(interp); */
03743         /* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */
03744         if (!Tcl_InterpDeleted(interp)) {
03745           ip_finalize(interp);
03746 
03747           Tcl_DeleteInterp(interp);
03748           Tcl_Release(interp);
03749         }
03750     }
03751     return TCL_OK;
03752 }
03753 
03754 static int
03755 #if TCL_MAJOR_VERSION >= 8
03756 #ifdef HAVE_PROTOTYPES
03757 ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp,
03758                   int argc, Tcl_Obj *CONST argv[])
03759 #else
03760 ip_RubyExitObjCmd(clientData, interp, argc, argv)
03761     ClientData clientData;
03762     Tcl_Interp *interp;
03763     int argc;
03764     Tcl_Obj *CONST argv[];
03765 #endif
03766 #else /* TCL_MAJOR_VERSION < 8 */
03767 #ifdef HAVE_PROTOTYPES
03768 ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp,
03769                    int argc, char *argv[])
03770 #else
03771 ip_RubyExitCommand(clientData, interp, argc, argv)
03772     ClientData clientData;
03773     Tcl_Interp *interp;
03774     int argc;
03775     char *argv[];
03776 #endif
03777 #endif
03778 {
03779     int state;
03780     char *cmd, *param;
03781 #if TCL_MAJOR_VERSION < 8
03782     char *endptr;
03783     cmd = argv[0];
03784 #endif
03785 
03786     DUMP1("start ip_RubyExitCommand");
03787 
03788 #if TCL_MAJOR_VERSION >= 8
03789     /* cmd = Tcl_GetString(argv[0]); */
03790     cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL);
03791 #endif
03792 
03793     if (argc < 1 || argc > 2) {
03794         /* arguemnt error */
03795         Tcl_AppendResult(interp,
03796                          "wrong number of arguments: should be \"",
03797                          cmd, " ?returnCode?\"", (char *)NULL);
03798         return TCL_ERROR;
03799     }
03800 
03801     if (interp == (Tcl_Interp*)NULL) return TCL_OK;
03802 
03803     Tcl_ResetResult(interp);
03804 
03805     if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) {
03806         if (!Tcl_InterpDeleted(interp)) {
03807           ip_finalize(interp);
03808 
03809           Tcl_DeleteInterp(interp);
03810           Tcl_Release(interp);
03811         }
03812         return TCL_OK;
03813     }
03814 
03815     switch(argc) {
03816     case 1:
03817         /* rb_exit(0); */ /* not return if succeed */
03818         Tcl_AppendResult(interp,
03819                          "fail to call \"", cmd, "\"", (char *)NULL);
03820 
03821         rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
03822                                              Tcl_GetStringResult(interp));
03823         rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));
03824 
03825         return TCL_RETURN;
03826 
03827     case 2:
03828 #if TCL_MAJOR_VERSION >= 8
03829         if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) {
03830             return TCL_ERROR;
03831         }
03832         /* param = Tcl_GetString(argv[1]); */
03833         param = Tcl_GetStringFromObj(argv[1], (int*)NULL);
03834 #else /* TCL_MAJOR_VERSION < 8 */
03835         state = (int)strtol(argv[1], &endptr, 0);
03836         if (*endptr) {
03837             Tcl_AppendResult(interp,
03838                              "expected integer but got \"",
03839                              argv[1], "\"", (char *)NULL);
03840             return TCL_ERROR;
03841         }
03842         param = argv[1];
03843 #endif
03844         /* rb_exit(state); */ /* not return if succeed */
03845 
03846         Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
03847                          param, "\"", (char *)NULL);
03848 
03849         rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
03850                                              Tcl_GetStringResult(interp));
03851         rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));
03852 
03853         return TCL_RETURN;
03854 
03855     default:
03856         /* arguemnt error */
03857         Tcl_AppendResult(interp,
03858                          "wrong number of arguments: should be \"",
03859                          cmd, " ?returnCode?\"", (char *)NULL);
03860         return TCL_ERROR;
03861     }
03862 }
03863 
03864 
03865 /**************************/
03866 /*  based on tclEvent.c   */
03867 /**************************/
03868 
03869 /*********************/
03870 /* replace of update */
03871 /*********************/
03872 #if TCL_MAJOR_VERSION >= 8
03873 static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
03874                                Tcl_Obj *CONST []));
03875 static int
03876 ip_rbUpdateObjCmd(clientData, interp, objc, objv)
03877     ClientData clientData;
03878     Tcl_Interp *interp;
03879     int objc;
03880     Tcl_Obj *CONST objv[];
03881 #else /* TCL_MAJOR_VERSION < 8 */
03882 static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
03883 static int
03884 ip_rbUpdateCommand(clientData, interp, objc, objv)
03885     ClientData clientData;
03886     Tcl_Interp *interp;
03887     int objc;
03888     char *objv[];
03889 #endif
03890 {
03891     int  optionIndex;
03892     int  ret;
03893     int  flags = 0;
03894     static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
03895     enum updateOptions {REGEXP_IDLETASKS};
03896 
03897     DUMP1("Ruby's 'update' is called");
03898     if (interp == (Tcl_Interp*)NULL) {
03899         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03900                                              "IP is deleted");
03901         return TCL_ERROR;
03902     }
03903 #ifdef HAVE_NATIVETHREAD
03904 #ifndef RUBY_USE_NATIVE_THREAD
03905     if (!ruby_native_thread_p()) {
03906         rb_bug("cross-thread violation on ip_ruby_eval()");
03907     }
03908 #endif
03909 #endif
03910 
03911     Tcl_ResetResult(interp);
03912 
03913     if (objc == 1) {
03914         flags = TCL_DONT_WAIT;
03915 
03916     } else if (objc == 2) {
03917 #if TCL_MAJOR_VERSION >= 8
03918         if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
03919                 "option", 0, &optionIndex) != TCL_OK) {
03920             return TCL_ERROR;
03921         }
03922         switch ((enum updateOptions) optionIndex) {
03923             case REGEXP_IDLETASKS: {
03924                 flags = TCL_IDLE_EVENTS;
03925                 break;
03926             }
03927             default: {
03928                 rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
03929             }
03930         }
03931 #else
03932         if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
03933             Tcl_AppendResult(interp, "bad option \"", objv[1],
03934                     "\": must be idletasks", (char *) NULL);
03935             return TCL_ERROR;
03936         }
03937         flags = TCL_IDLE_EVENTS;
03938 #endif
03939     } else {
03940 #ifdef Tcl_WrongNumArgs
03941         Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
03942 #else
03943 # if TCL_MAJOR_VERSION >= 8
03944         int  dummy;
03945         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
03946                          Tcl_GetStringFromObj(objv[0], &dummy),
03947                          " [ idletasks ]\"",
03948                          (char *) NULL);
03949 # else /* TCL_MAJOR_VERSION < 8 */
03950         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
03951                          objv[0], " [ idletasks ]\"", (char *) NULL);
03952 # endif
03953 #endif
03954         return TCL_ERROR;
03955     }
03956 
03957     Tcl_Preserve(interp);
03958 
03959     /* call eventloop */
03960     /* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */
03961     ret = RTEST(lib_eventloop_launcher(0, flags, (int *)NULL, interp)); /* ignore result */
03962 
03963     /* exception check */
03964     if (!NIL_P(rbtk_pending_exception)) {
03965         Tcl_Release(interp);
03966 
03967         /*
03968         if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
03969         */
03970         if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
03971             || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
03972             return TCL_RETURN;
03973         } else{
03974             return TCL_ERROR;
03975         }
03976     }
03977 
03978     /* trap check */
03979 #ifdef RUBY_VM
03980     if (rb_thread_check_trap_pending()) {
03981 #else
03982     if (rb_trap_pending) {
03983 #endif
03984         Tcl_Release(interp);
03985 
03986         return TCL_RETURN;
03987     }
03988 
03989     /*
03990      * Must clear the interpreter's result because event handlers could
03991      * have executed commands.
03992      */
03993 
03994     DUMP2("last result '%s'", Tcl_GetStringResult(interp));
03995     Tcl_ResetResult(interp);
03996     Tcl_Release(interp);
03997 
03998     DUMP1("finish Ruby's 'update'");
03999     return TCL_OK;
04000 }
04001 
04002 
04003 /**********************/
04004 /* update with thread */
04005 /**********************/
04006 struct th_update_param {
04007     VALUE thread;
04008     int   done;
04009 };
04010 
04011 static void rb_threadUpdateProc _((ClientData));
04012 static void
04013 rb_threadUpdateProc(clientData)
04014     ClientData clientData;      /* Pointer to integer to set to 1. */
04015 {
04016     struct th_update_param *param = (struct th_update_param *) clientData;
04017 
04018     DUMP1("threadUpdateProc is called");
04019     param->done = 1;
04020     rb_thread_wakeup(param->thread);
04021 
04022     return;
04023 }
04024 
04025 #if TCL_MAJOR_VERSION >= 8
04026 static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int,
04027                                        Tcl_Obj *CONST []));
04028 static int
04029 ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv)
04030     ClientData clientData;
04031     Tcl_Interp *interp;
04032     int objc;
04033     Tcl_Obj *CONST objv[];
04034 #else /* TCL_MAJOR_VERSION < 8 */
04035 static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int,
04036                                        char *[]));
04037 static int
04038 ip_rb_threadUpdateCommand(clientData, interp, objc, objv)
04039     ClientData clientData;
04040     Tcl_Interp *interp;
04041     int objc;
04042     char *objv[];
04043 #endif
04044 {
04045     int  optionIndex;
04046     int  flags = 0;
04047     struct th_update_param *param;
04048     static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
04049     enum updateOptions {REGEXP_IDLETASKS};
04050     volatile VALUE current_thread = rb_thread_current();
04051     struct timeval t;
04052 
04053     DUMP1("Ruby's 'thread_update' is called");
04054     if (interp == (Tcl_Interp*)NULL) {
04055         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04056                                              "IP is deleted");
04057         return TCL_ERROR;
04058     }
04059 #ifdef HAVE_NATIVETHREAD
04060 #ifndef RUBY_USE_NATIVE_THREAD
04061     if (!ruby_native_thread_p()) {
04062         rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()");
04063     }
04064 #endif
04065 #endif
04066 
04067     if (rb_thread_alone()
04068         || NIL_P(eventloop_thread) || eventloop_thread == current_thread) {
04069 #if TCL_MAJOR_VERSION >= 8
04070         DUMP1("call ip_rbUpdateObjCmd");
04071         return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
04072 #else /* TCL_MAJOR_VERSION < 8 */
04073         DUMP1("call ip_rbUpdateCommand");
04074         return ip_rbUpdateCommand(clientData, interp, objc, objv);
04075 #endif
04076     }
04077 
04078     DUMP1("start Ruby's 'thread_update' body");
04079 
04080     Tcl_ResetResult(interp);
04081 
04082     if (objc == 1) {
04083         flags = TCL_DONT_WAIT;
04084 
04085     } else if (objc == 2) {
04086 #if TCL_MAJOR_VERSION >= 8
04087         if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
04088                 "option", 0, &optionIndex) != TCL_OK) {
04089             return TCL_ERROR;
04090         }
04091         switch ((enum updateOptions) optionIndex) {
04092             case REGEXP_IDLETASKS: {
04093                 flags = TCL_IDLE_EVENTS;
04094                 break;
04095             }
04096             default: {
04097                 rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
04098             }
04099         }
04100 #else
04101         if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
04102             Tcl_AppendResult(interp, "bad option \"", objv[1],
04103                     "\": must be idletasks", (char *) NULL);
04104             return TCL_ERROR;
04105         }
04106         flags = TCL_IDLE_EVENTS;
04107 #endif
04108     } else {
04109 #ifdef Tcl_WrongNumArgs
04110         Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
04111 #else
04112 # if TCL_MAJOR_VERSION >= 8
04113         int  dummy;
04114         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04115                          Tcl_GetStringFromObj(objv[0], &dummy),
04116                          " [ idletasks ]\"",
04117                          (char *) NULL);
04118 # else /* TCL_MAJOR_VERSION < 8 */
04119         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04120                          objv[0], " [ idletasks ]\"", (char *) NULL);
04121 # endif
04122 #endif
04123         return TCL_ERROR;
04124     }
04125 
04126     DUMP1("pass argument check");
04127 
04128     /* param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); */
04129     param = RbTk_ALLOC_N(struct th_update_param, 1);
04130 #if 0 /* use Tcl_Preserve/Release */
04131     Tcl_Preserve((ClientData)param);
04132 #endif
04133     param->thread = current_thread;
04134     param->done = 0;
04135 
04136     DUMP1("set idle proc");
04137     Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param);
04138 
04139     t.tv_sec  = 0;
04140     t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
04141 
04142     while(!param->done) {
04143       DUMP1("wait for complete idle proc");
04144       /* rb_thread_stop(); */
04145       /* rb_thread_sleep_forever(); */
04146       rb_thread_wait_for(t);
04147       if (NIL_P(eventloop_thread)) {
04148         break;
04149       }
04150     }
04151 
04152 #if 0 /* use Tcl_EventuallyFree */
04153         Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
04154 #else
04155 #if 0 /* use Tcl_Preserve/Release */
04156     Tcl_Release((ClientData)param);
04157 #else
04158     /* Tcl_Free((char *)param); */
04159     ckfree((char *)param);
04160 #endif
04161 #endif
04162 
04163     DUMP1("finish Ruby's 'thread_update'");
04164     return TCL_OK;
04165 }
04166 
04167 
04168 /***************************/
04169 /* replace of vwait/tkwait */
04170 /***************************/
04171 #if TCL_MAJOR_VERSION >= 8
04172 static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int,
04173                                Tcl_Obj *CONST []));
04174 static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int,
04175                                       Tcl_Obj *CONST []));
04176 static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
04177                                 Tcl_Obj *CONST []));
04178 static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
04179                                        Tcl_Obj *CONST []));
04180 #else
04181 static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
04182 static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int,
04183                                        char *[]));
04184 static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
04185 static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int,
04186                                         char *[]));
04187 #endif
04188 
04189 #if TCL_MAJOR_VERSION >= 8
04190 static char *VwaitVarProc _((ClientData, Tcl_Interp *,
04191                              CONST84 char *,CONST84 char *, int));
04192 static char *
04193 VwaitVarProc(clientData, interp, name1, name2, flags)
04194     ClientData clientData;      /* Pointer to integer to set to 1. */
04195     Tcl_Interp *interp;         /* Interpreter containing variable. */
04196     CONST84 char *name1;        /* Name of variable. */
04197     CONST84 char *name2;        /* Second part of variable name. */
04198     int flags;                  /* Information about what happened. */
04199 #else /* TCL_MAJOR_VERSION < 8 */
04200 static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int));
04201 static char *
04202 VwaitVarProc(clientData, interp, name1, name2, flags)
04203     ClientData clientData;      /* Pointer to integer to set to 1. */
04204     Tcl_Interp *interp;         /* Interpreter containing variable. */
04205     char *name1;                /* Name of variable. */
04206     char *name2;                /* Second part of variable name. */
04207     int flags;                  /* Information about what happened. */
04208 #endif
04209 {
04210     int *donePtr = (int *) clientData;
04211 
04212     *donePtr = 1;
04213     return (char *) NULL;
04214 }
04215 
04216 #if TCL_MAJOR_VERSION >= 8
04217 static int
04218 ip_rbVwaitObjCmd(clientData, interp, objc, objv)
04219     ClientData clientData; /* Not used */
04220     Tcl_Interp *interp;
04221     int objc;
04222     Tcl_Obj *CONST objv[];
04223 #else /* TCL_MAJOR_VERSION < 8 */
04224 static int
04225 ip_rbVwaitCommand(clientData, interp, objc, objv)
04226     ClientData clientData; /* Not used */
04227     Tcl_Interp *interp;
04228     int objc;
04229     char *objv[];
04230 #endif
04231 {
04232     int  ret, done, foundEvent;
04233     char *nameString;
04234     int  dummy;
04235     int thr_crit_bup;
04236 
04237     DUMP1("Ruby's 'vwait' is called");
04238     if (interp == (Tcl_Interp*)NULL) {
04239         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04240                                              "IP is deleted");
04241         return TCL_ERROR;
04242     }
04243 
04244 #if 0
04245     if (!rb_thread_alone()
04246         && eventloop_thread != Qnil
04247         && eventloop_thread != rb_thread_current()) {
04248 #if TCL_MAJOR_VERSION >= 8
04249         DUMP1("call ip_rb_threadVwaitObjCmd");
04250         return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv);
04251 #else /* TCL_MAJOR_VERSION < 8 */
04252         DUMP1("call ip_rb_threadVwaitCommand");
04253         return ip_rb_threadVwaitCommand(clientData, interp, objc, objv);
04254 #endif
04255     }
04256 #endif
04257 
04258     Tcl_Preserve(interp);
04259 #ifdef HAVE_NATIVETHREAD
04260 #ifndef RUBY_USE_NATIVE_THREAD
04261     if (!ruby_native_thread_p()) {
04262         rb_bug("cross-thread violation on ip_rbVwaitCommand()");
04263     }
04264 #endif
04265 #endif
04266 
04267     Tcl_ResetResult(interp);
04268 
04269     if (objc != 2) {
04270 #ifdef Tcl_WrongNumArgs
04271         Tcl_WrongNumArgs(interp, 1, objv, "name");
04272 #else
04273         thr_crit_bup = rb_thread_critical;
04274         rb_thread_critical = Qtrue;
04275 
04276 #if TCL_MAJOR_VERSION >= 8
04277         /* nameString = Tcl_GetString(objv[0]); */
04278         nameString = Tcl_GetStringFromObj(objv[0], &dummy);
04279 #else /* TCL_MAJOR_VERSION < 8 */
04280         nameString = objv[0];
04281 #endif
04282         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04283                          nameString, " name\"", (char *) NULL);
04284 
04285         rb_thread_critical = thr_crit_bup;
04286 #endif
04287 
04288         Tcl_Release(interp);
04289         return TCL_ERROR;
04290     }
04291 
04292     thr_crit_bup = rb_thread_critical;
04293     rb_thread_critical = Qtrue;
04294 
04295 #if TCL_MAJOR_VERSION >= 8
04296     Tcl_IncrRefCount(objv[1]);
04297     /* nameString = Tcl_GetString(objv[1]); */
04298     nameString = Tcl_GetStringFromObj(objv[1], &dummy);
04299 #else /* TCL_MAJOR_VERSION < 8 */
04300     nameString = objv[1];
04301 #endif
04302 
04303     /*
04304     if (Tcl_TraceVar(interp, nameString,
04305                      TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04306                      VwaitVarProc, (ClientData) &done) != TCL_OK) {
04307         return TCL_ERROR;
04308     }
04309     */
04310     ret = Tcl_TraceVar(interp, nameString,
04311                        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04312                        VwaitVarProc, (ClientData) &done);
04313 
04314     rb_thread_critical = thr_crit_bup;
04315 
04316     if (ret != TCL_OK) {
04317 #if TCL_MAJOR_VERSION >= 8
04318         Tcl_DecrRefCount(objv[1]);
04319 #endif
04320         Tcl_Release(interp);
04321         return TCL_ERROR;
04322     }
04323 
04324     done = 0;
04325 
04326     foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0,
04327                                               0, &done, interp));
04328 
04329     thr_crit_bup = rb_thread_critical;
04330     rb_thread_critical = Qtrue;
04331 
04332     Tcl_UntraceVar(interp, nameString,
04333                    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04334                    VwaitVarProc, (ClientData) &done);
04335 
04336     rb_thread_critical = thr_crit_bup;
04337 
04338     /* exception check */
04339     if (!NIL_P(rbtk_pending_exception)) {
04340 #if TCL_MAJOR_VERSION >= 8
04341         Tcl_DecrRefCount(objv[1]);
04342 #endif
04343         Tcl_Release(interp);
04344 
04345 /*
04346         if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
04347 */
04348         if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04349             || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04350             return TCL_RETURN;
04351         } else{
04352             return TCL_ERROR;
04353         }
04354     }
04355 
04356     /* trap check */
04357 #ifdef RUBY_VM
04358     if (rb_thread_check_trap_pending()) {
04359 #else
04360     if (rb_trap_pending) {
04361 #endif
04362 #if TCL_MAJOR_VERSION >= 8
04363         Tcl_DecrRefCount(objv[1]);
04364 #endif
04365         Tcl_Release(interp);
04366 
04367         return TCL_RETURN;
04368     }
04369 
04370     /*
04371      * Clear out the interpreter's result, since it may have been set
04372      * by event handlers.
04373      */
04374 
04375     Tcl_ResetResult(interp);
04376     if (!foundEvent) {
04377         thr_crit_bup = rb_thread_critical;
04378         rb_thread_critical = Qtrue;
04379 
04380         Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
04381                          "\":  would wait forever", (char *) NULL);
04382 
04383         rb_thread_critical = thr_crit_bup;
04384 
04385 #if TCL_MAJOR_VERSION >= 8
04386         Tcl_DecrRefCount(objv[1]);
04387 #endif
04388         Tcl_Release(interp);
04389         return TCL_ERROR;
04390     }
04391 
04392 #if TCL_MAJOR_VERSION >= 8
04393     Tcl_DecrRefCount(objv[1]);
04394 #endif
04395     Tcl_Release(interp);
04396     return TCL_OK;
04397 }
04398 
04399 
04400 /**************************/
04401 /*  based on tkCmd.c      */
04402 /**************************/
04403 #if TCL_MAJOR_VERSION >= 8
04404 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
04405                                  CONST84 char *,CONST84 char *, int));
04406 static char *
04407 WaitVariableProc(clientData, interp, name1, name2, flags)
04408     ClientData clientData;      /* Pointer to integer to set to 1. */
04409     Tcl_Interp *interp;         /* Interpreter containing variable. */
04410     CONST84 char *name1;        /* Name of variable. */
04411     CONST84 char *name2;        /* Second part of variable name. */
04412     int flags;                  /* Information about what happened. */
04413 #else /* TCL_MAJOR_VERSION < 8 */
04414 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
04415                                  char *, char *, int));
04416 static char *
04417 WaitVariableProc(clientData, interp, name1, name2, flags)
04418     ClientData clientData;      /* Pointer to integer to set to 1. */
04419     Tcl_Interp *interp;         /* Interpreter containing variable. */
04420     char *name1;                /* Name of variable. */
04421     char *name2;                /* Second part of variable name. */
04422     int flags;                  /* Information about what happened. */
04423 #endif
04424 {
04425     int *donePtr = (int *) clientData;
04426 
04427     *donePtr = 1;
04428     return (char *) NULL;
04429 }
04430 
04431 static void WaitVisibilityProc _((ClientData, XEvent *));
04432 static void
04433 WaitVisibilityProc(clientData, eventPtr)
04434     ClientData clientData;      /* Pointer to integer to set to 1. */
04435     XEvent *eventPtr;           /* Information about event (not used). */
04436 {
04437     int *donePtr = (int *) clientData;
04438 
04439     if (eventPtr->type == VisibilityNotify) {
04440         *donePtr = 1;
04441     }
04442     if (eventPtr->type == DestroyNotify) {
04443         *donePtr = 2;
04444     }
04445 }
04446 
04447 static void WaitWindowProc _((ClientData, XEvent *));
04448 static void
04449 WaitWindowProc(clientData, eventPtr)
04450     ClientData clientData;      /* Pointer to integer to set to 1. */
04451     XEvent *eventPtr;           /* Information about event. */
04452 {
04453     int *donePtr = (int *) clientData;
04454 
04455     if (eventPtr->type == DestroyNotify) {
04456         *donePtr = 1;
04457     }
04458 }
04459 
04460 #if TCL_MAJOR_VERSION >= 8
04461 static int
04462 ip_rbTkWaitObjCmd(clientData, interp, objc, objv)
04463     ClientData clientData;
04464     Tcl_Interp *interp;
04465     int objc;
04466     Tcl_Obj *CONST objv[];
04467 #else /* TCL_MAJOR_VERSION < 8 */
04468 static int
04469 ip_rbTkWaitCommand(clientData, interp, objc, objv)
04470     ClientData clientData;
04471     Tcl_Interp *interp;
04472     int objc;
04473     char *objv[];
04474 #endif
04475 {
04476     Tk_Window tkwin = (Tk_Window) clientData;
04477     Tk_Window window;
04478     int done, index;
04479     static CONST char *optionStrings[] = { "variable", "visibility", "window",
04480                                            (char *) NULL };
04481     enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
04482     char *nameString;
04483     int ret, dummy;
04484     int thr_crit_bup;
04485 
04486     DUMP1("Ruby's 'tkwait' is called");
04487     if (interp == (Tcl_Interp*)NULL) {
04488         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04489                                              "IP is deleted");
04490         return TCL_ERROR;
04491     }
04492 
04493 #if 0
04494     if (!rb_thread_alone()
04495         && eventloop_thread != Qnil
04496         && eventloop_thread != rb_thread_current()) {
04497 #if TCL_MAJOR_VERSION >= 8
04498         DUMP1("call ip_rb_threadTkWaitObjCmd");
04499         return ip_rb_threadTkWaitObjCmd((ClientData)tkwin, interp, objc, objv);
04500 #else /* TCL_MAJOR_VERSION < 8 */
04501         DUMP1("call ip_rb_threadTkWaitCommand");
04502         return ip_rb_threadTkWwaitCommand((ClientData)tkwin, interp, objc, objv);
04503 #endif
04504     }
04505 #endif
04506 
04507     Tcl_Preserve(interp);
04508     Tcl_ResetResult(interp);
04509 
04510     if (objc != 3) {
04511 #ifdef Tcl_WrongNumArgs
04512         Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
04513 #else
04514         thr_crit_bup = rb_thread_critical;
04515         rb_thread_critical = Qtrue;
04516 
04517 #if TCL_MAJOR_VERSION >= 8
04518         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04519                          Tcl_GetStringFromObj(objv[0], &dummy),
04520                          " variable|visibility|window name\"",
04521                          (char *) NULL);
04522 #else /* TCL_MAJOR_VERSION < 8 */
04523         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04524                          objv[0], " variable|visibility|window name\"",
04525                          (char *) NULL);
04526 #endif
04527 
04528         rb_thread_critical = thr_crit_bup;
04529 #endif
04530 
04531         Tcl_Release(interp);
04532         return TCL_ERROR;
04533     }
04534 
04535 #if TCL_MAJOR_VERSION >= 8
04536     thr_crit_bup = rb_thread_critical;
04537     rb_thread_critical = Qtrue;
04538 
04539     /*
04540     if (Tcl_GetIndexFromObj(interp, objv[1],
04541                             (CONST84 char **)optionStrings,
04542                             "option", 0, &index) != TCL_OK) {
04543         return TCL_ERROR;
04544     }
04545     */
04546     ret = Tcl_GetIndexFromObj(interp, objv[1],
04547                               (CONST84 char **)optionStrings,
04548                               "option", 0, &index);
04549 
04550     rb_thread_critical = thr_crit_bup;
04551 
04552     if (ret != TCL_OK) {
04553         Tcl_Release(interp);
04554         return TCL_ERROR;
04555     }
04556 #else /* TCL_MAJOR_VERSION < 8 */
04557     {
04558         int c = objv[1][0];
04559         size_t length = strlen(objv[1]);
04560 
04561         if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
04562             && (length >= 2)) {
04563             index = TKWAIT_VARIABLE;
04564         } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
04565                    && (length >= 2)) {
04566             index = TKWAIT_VISIBILITY;
04567         } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
04568             index = TKWAIT_WINDOW;
04569         } else {
04570             Tcl_AppendResult(interp, "bad option \"", objv[1],
04571                              "\": must be variable, visibility, or window",
04572                              (char *) NULL);
04573             Tcl_Release(interp);
04574             return TCL_ERROR;
04575         }
04576     }
04577 #endif
04578 
04579     thr_crit_bup = rb_thread_critical;
04580     rb_thread_critical = Qtrue;
04581 
04582 #if TCL_MAJOR_VERSION >= 8
04583     Tcl_IncrRefCount(objv[2]);
04584     /* nameString = Tcl_GetString(objv[2]); */
04585     nameString = Tcl_GetStringFromObj(objv[2], &dummy);
04586 #else /* TCL_MAJOR_VERSION < 8 */
04587     nameString = objv[2];
04588 #endif
04589 
04590     rb_thread_critical = thr_crit_bup;
04591 
04592     switch ((enum options) index) {
04593     case TKWAIT_VARIABLE:
04594         thr_crit_bup = rb_thread_critical;
04595         rb_thread_critical = Qtrue;
04596         /*
04597         if (Tcl_TraceVar(interp, nameString,
04598                          TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04599                          WaitVariableProc, (ClientData) &done) != TCL_OK) {
04600             return TCL_ERROR;
04601         }
04602         */
04603         ret = Tcl_TraceVar(interp, nameString,
04604                            TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04605                            WaitVariableProc, (ClientData) &done);
04606 
04607         rb_thread_critical = thr_crit_bup;
04608 
04609         if (ret != TCL_OK) {
04610 #if TCL_MAJOR_VERSION >= 8
04611             Tcl_DecrRefCount(objv[2]);
04612 #endif
04613             Tcl_Release(interp);
04614             return TCL_ERROR;
04615         }
04616 
04617         done = 0;
04618         /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
04619         lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04620 
04621         thr_crit_bup = rb_thread_critical;
04622         rb_thread_critical = Qtrue;
04623 
04624         Tcl_UntraceVar(interp, nameString,
04625                        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04626                        WaitVariableProc, (ClientData) &done);
04627 
04628 #if TCL_MAJOR_VERSION >= 8
04629         Tcl_DecrRefCount(objv[2]);
04630 #endif
04631 
04632         rb_thread_critical = thr_crit_bup;
04633 
04634         /* exception check */
04635         if (!NIL_P(rbtk_pending_exception)) {
04636             Tcl_Release(interp);
04637 
04638             /*
04639             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
04640             */
04641             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04642                 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04643                 return TCL_RETURN;
04644             } else{
04645                 return TCL_ERROR;
04646             }
04647         }
04648 
04649         /* trap check */
04650 #ifdef RUBY_VM
04651         if (rb_thread_check_trap_pending()) {
04652 #else
04653         if (rb_trap_pending) {
04654 #endif
04655             Tcl_Release(interp);
04656 
04657             return TCL_RETURN;
04658         }
04659 
04660         break;
04661 
04662     case TKWAIT_VISIBILITY:
04663         thr_crit_bup = rb_thread_critical;
04664         rb_thread_critical = Qtrue;
04665 
04666         /* This function works on the Tk eventloop thread only. */
04667         if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
04668             window = NULL;
04669         } else {
04670             window = Tk_NameToWindow(interp, nameString, tkwin);
04671         }
04672 
04673         if (window == NULL) {
04674             Tcl_AppendResult(interp, ": tkwait: ",
04675                              "no main-window (not Tk application?)",
04676                              (char*)NULL);
04677             rb_thread_critical = thr_crit_bup;
04678 #if TCL_MAJOR_VERSION >= 8
04679             Tcl_DecrRefCount(objv[2]);
04680 #endif
04681             Tcl_Release(interp);
04682             return TCL_ERROR;
04683         }
04684 
04685         Tk_CreateEventHandler(window,
04686                               VisibilityChangeMask|StructureNotifyMask,
04687                               WaitVisibilityProc, (ClientData) &done);
04688 
04689         rb_thread_critical = thr_crit_bup;
04690 
04691         done = 0;
04692         /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
04693         lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04694 
04695         /* exception check */
04696         if (!NIL_P(rbtk_pending_exception)) {
04697 #if TCL_MAJOR_VERSION >= 8
04698             Tcl_DecrRefCount(objv[2]);
04699 #endif
04700             Tcl_Release(interp);
04701 
04702             /*
04703             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
04704             */
04705             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04706                 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04707                 return TCL_RETURN;
04708             } else{
04709                 return TCL_ERROR;
04710             }
04711         }
04712 
04713         /* trap check */
04714 #ifdef RUBY_VM
04715         if (rb_thread_check_trap_pending()) {
04716 #else
04717         if (rb_trap_pending) {
04718 #endif
04719 #if TCL_MAJOR_VERSION >= 8
04720             Tcl_DecrRefCount(objv[2]);
04721 #endif
04722             Tcl_Release(interp);
04723 
04724             return TCL_RETURN;
04725         }
04726 
04727         if (done != 1) {
04728             /*
04729              * Note that we do not delete the event handler because it
04730              * was deleted automatically when the window was destroyed.
04731              */
04732             thr_crit_bup = rb_thread_critical;
04733             rb_thread_critical = Qtrue;
04734 
04735             Tcl_ResetResult(interp);
04736             Tcl_AppendResult(interp, "window \"", nameString,
04737                              "\" was deleted before its visibility changed",
04738                              (char *) NULL);
04739 
04740             rb_thread_critical = thr_crit_bup;
04741 
04742 #if TCL_MAJOR_VERSION >= 8
04743             Tcl_DecrRefCount(objv[2]);
04744 #endif
04745             Tcl_Release(interp);
04746             return TCL_ERROR;
04747         }
04748 
04749         thr_crit_bup = rb_thread_critical;
04750         rb_thread_critical = Qtrue;
04751 
04752 #if TCL_MAJOR_VERSION >= 8
04753         Tcl_DecrRefCount(objv[2]);
04754 #endif
04755 
04756         Tk_DeleteEventHandler(window,
04757                               VisibilityChangeMask|StructureNotifyMask,
04758                               WaitVisibilityProc, (ClientData) &done);
04759 
04760         rb_thread_critical = thr_crit_bup;
04761 
04762         break;
04763 
04764     case TKWAIT_WINDOW:
04765         thr_crit_bup = rb_thread_critical;
04766         rb_thread_critical = Qtrue;
04767 
04768         /* This function works on the Tk eventloop thread only. */
04769         if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
04770             window = NULL;
04771         } else {
04772             window = Tk_NameToWindow(interp, nameString, tkwin);
04773         }
04774 
04775 #if TCL_MAJOR_VERSION >= 8
04776         Tcl_DecrRefCount(objv[2]);
04777 #endif
04778 
04779         if (window == NULL) {
04780             Tcl_AppendResult(interp, ": tkwait: ",
04781                              "no main-window (not Tk application?)",
04782                              (char*)NULL);
04783             rb_thread_critical = thr_crit_bup;
04784             Tcl_Release(interp);
04785             return TCL_ERROR;
04786         }
04787 
04788         Tk_CreateEventHandler(window, StructureNotifyMask,
04789                               WaitWindowProc, (ClientData) &done);
04790 
04791         rb_thread_critical = thr_crit_bup;
04792 
04793         done = 0;
04794         /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
04795         lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04796 
04797         /* exception check */
04798         if (!NIL_P(rbtk_pending_exception)) {
04799             Tcl_Release(interp);
04800 
04801             /*
04802             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
04803             */
04804             if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04805                 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04806                 return TCL_RETURN;
04807             } else{
04808                 return TCL_ERROR;
04809             }
04810         }
04811 
04812         /* trap check */
04813 #ifdef RUBY_VM
04814         if (rb_thread_check_trap_pending()) {
04815 #else
04816         if (rb_trap_pending) {
04817 #endif
04818             Tcl_Release(interp);
04819 
04820             return TCL_RETURN;
04821         }
04822 
04823         /*
04824          * Note:  there's no need to delete the event handler.  It was
04825          * deleted automatically when the window was destroyed.
04826          */
04827         break;
04828     }
04829 
04830     /*
04831      * Clear out the interpreter's result, since it may have been set
04832      * by event handlers.
04833      */
04834 
04835     Tcl_ResetResult(interp);
04836     Tcl_Release(interp);
04837     return TCL_OK;
04838 }
04839 
04840 /****************************/
04841 /* vwait/tkwait with thread */
04842 /****************************/
04843 struct th_vwait_param {
04844     VALUE thread;
04845     int   done;
04846 };
04847 
04848 #if TCL_MAJOR_VERSION >= 8
04849 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
04850                                    CONST84 char *,CONST84 char *, int));
04851 static char *
04852 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
04853     ClientData clientData;      /* Pointer to integer to set to 1. */
04854     Tcl_Interp *interp;         /* Interpreter containing variable. */
04855     CONST84 char *name1;        /* Name of variable. */
04856     CONST84 char *name2;        /* Second part of variable name. */
04857     int flags;                  /* Information about what happened. */
04858 #else /* TCL_MAJOR_VERSION < 8 */
04859 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
04860                                    char *, char *, int));
04861 static char *
04862 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
04863     ClientData clientData;      /* Pointer to integer to set to 1. */
04864     Tcl_Interp *interp;         /* Interpreter containing variable. */
04865     char *name1;                /* Name of variable. */
04866     char *name2;                /* Second part of variable name. */
04867     int flags;                  /* Information about what happened. */
04868 #endif
04869 {
04870     struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04871 
04872     if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) {
04873         param->done = -1;
04874     } else {
04875         param->done = 1;
04876     }
04877     if (param->done != 0) rb_thread_wakeup(param->thread);
04878 
04879     return (char *)NULL;
04880 }
04881 
04882 #define TKWAIT_MODE_VISIBILITY 1
04883 #define TKWAIT_MODE_DESTROY    2
04884 
04885 static void rb_threadWaitVisibilityProc _((ClientData, XEvent *));
04886 static void
04887 rb_threadWaitVisibilityProc(clientData, eventPtr)
04888     ClientData clientData;      /* Pointer to integer to set to 1. */
04889     XEvent *eventPtr;           /* Information about event (not used). */
04890 {
04891     struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04892 
04893     if (eventPtr->type == VisibilityNotify) {
04894         param->done = TKWAIT_MODE_VISIBILITY;
04895     }
04896     if (eventPtr->type == DestroyNotify) {
04897         param->done = TKWAIT_MODE_DESTROY;
04898     }
04899     if (param->done != 0) rb_thread_wakeup(param->thread);
04900 }
04901 
04902 static void rb_threadWaitWindowProc _((ClientData, XEvent *));
04903 static void
04904 rb_threadWaitWindowProc(clientData, eventPtr)
04905     ClientData clientData;      /* Pointer to integer to set to 1. */
04906     XEvent *eventPtr;           /* Information about event. */
04907 {
04908     struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04909 
04910     if (eventPtr->type == DestroyNotify) {
04911         param->done = TKWAIT_MODE_DESTROY;
04912     }
04913     if (param->done != 0) rb_thread_wakeup(param->thread);
04914 }
04915 
04916 #if TCL_MAJOR_VERSION >= 8
04917 static int
04918 ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv)
04919     ClientData clientData;
04920     Tcl_Interp *interp;
04921     int objc;
04922     Tcl_Obj *CONST objv[];
04923 #else /* TCL_MAJOR_VERSION < 8 */
04924 static int
04925 ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
04926     ClientData clientData; /* Not used */
04927     Tcl_Interp *interp;
04928     int objc;
04929     char *objv[];
04930 #endif
04931 {
04932     struct th_vwait_param *param;
04933     char *nameString;
04934     int ret, dummy;
04935     int thr_crit_bup;
04936     volatile VALUE current_thread = rb_thread_current();
04937     struct timeval t;
04938 
04939     DUMP1("Ruby's 'thread_vwait' is called");
04940     if (interp == (Tcl_Interp*)NULL) {
04941         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04942                                              "IP is deleted");
04943         return TCL_ERROR;
04944     }
04945 
04946     if (rb_thread_alone() || eventloop_thread == current_thread) {
04947 #if TCL_MAJOR_VERSION >= 8
04948         DUMP1("call ip_rbVwaitObjCmd");
04949         return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
04950 #else /* TCL_MAJOR_VERSION < 8 */
04951         DUMP1("call ip_rbVwaitCommand");
04952         return ip_rbVwaitCommand(clientData, interp, objc, objv);
04953 #endif
04954     }
04955 
04956     Tcl_Preserve(interp);
04957     Tcl_ResetResult(interp);
04958 
04959     if (objc != 2) {
04960 #ifdef Tcl_WrongNumArgs
04961         Tcl_WrongNumArgs(interp, 1, objv, "name");
04962 #else
04963         thr_crit_bup = rb_thread_critical;
04964         rb_thread_critical = Qtrue;
04965 
04966 #if TCL_MAJOR_VERSION >= 8
04967         /* nameString = Tcl_GetString(objv[0]); */
04968         nameString = Tcl_GetStringFromObj(objv[0], &dummy);
04969 #else /* TCL_MAJOR_VERSION < 8 */
04970         nameString = objv[0];
04971 #endif
04972         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04973                          nameString, " name\"", (char *) NULL);
04974 
04975         rb_thread_critical = thr_crit_bup;
04976 #endif
04977 
04978         Tcl_Release(interp);
04979         return TCL_ERROR;
04980     }
04981 
04982 #if TCL_MAJOR_VERSION >= 8
04983     Tcl_IncrRefCount(objv[1]);
04984     /* nameString = Tcl_GetString(objv[1]); */
04985     nameString = Tcl_GetStringFromObj(objv[1], &dummy);
04986 #else /* TCL_MAJOR_VERSION < 8 */
04987     nameString = objv[1];
04988 #endif
04989     thr_crit_bup = rb_thread_critical;
04990     rb_thread_critical = Qtrue;
04991 
04992     /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
04993     param = RbTk_ALLOC_N(struct th_vwait_param, 1);
04994 #if 1 /* use Tcl_Preserve/Release */
04995     Tcl_Preserve((ClientData)param);
04996 #endif
04997     param->thread = current_thread;
04998     param->done = 0;
04999 
05000     /*
05001     if (Tcl_TraceVar(interp, nameString,
05002                      TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05003                      rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
05004         return TCL_ERROR;
05005     }
05006     */
05007     ret = Tcl_TraceVar(interp, nameString,
05008                        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05009                        rb_threadVwaitProc, (ClientData) param);
05010 
05011     rb_thread_critical = thr_crit_bup;
05012 
05013     if (ret != TCL_OK) {
05014 #if 0 /* use Tcl_EventuallyFree */
05015         Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05016 #else
05017 #if 1 /* use Tcl_Preserve/Release */
05018         Tcl_Release((ClientData)param);
05019 #else
05020         /* Tcl_Free((char *)param); */
05021         ckfree((char *)param);
05022 #endif
05023 #endif
05024 
05025 #if TCL_MAJOR_VERSION >= 8
05026         Tcl_DecrRefCount(objv[1]);
05027 #endif
05028         Tcl_Release(interp);
05029         return TCL_ERROR;
05030     }
05031 
05032     t.tv_sec  = 0;
05033     t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05034 
05035     while(!param->done) {
05036       /* rb_thread_stop(); */
05037       /* rb_thread_sleep_forever(); */
05038       rb_thread_wait_for(t);
05039       if (NIL_P(eventloop_thread)) {
05040         break;
05041       }
05042     }
05043 
05044     thr_crit_bup = rb_thread_critical;
05045     rb_thread_critical = Qtrue;
05046 
05047     if (param->done > 0) {
05048         Tcl_UntraceVar(interp, nameString,
05049                        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05050                        rb_threadVwaitProc, (ClientData) param);
05051     }
05052 
05053 #if 0 /* use Tcl_EventuallyFree */
05054     Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05055 #else
05056 #if 1 /* use Tcl_Preserve/Release */
05057     Tcl_Release((ClientData)param);
05058 #else
05059     /* Tcl_Free((char *)param); */
05060     ckfree((char *)param);
05061 #endif
05062 #endif
05063 
05064     rb_thread_critical = thr_crit_bup;
05065 
05066 #if TCL_MAJOR_VERSION >= 8
05067     Tcl_DecrRefCount(objv[1]);
05068 #endif
05069     Tcl_Release(interp);
05070     return TCL_OK;
05071 }
05072 
05073 #if TCL_MAJOR_VERSION >= 8
05074 static int
05075 ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv)
05076     ClientData clientData;
05077     Tcl_Interp *interp;
05078     int objc;
05079     Tcl_Obj *CONST objv[];
05080 #else /* TCL_MAJOR_VERSION < 8 */
05081 static int
05082 ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
05083     ClientData clientData;
05084     Tcl_Interp *interp;
05085     int objc;
05086     char *objv[];
05087 #endif
05088 {
05089     struct th_vwait_param *param;
05090     Tk_Window tkwin = (Tk_Window) clientData;
05091     Tk_Window window;
05092     int index;
05093     static CONST char *optionStrings[] = { "variable", "visibility", "window",
05094                                            (char *) NULL };
05095     enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
05096     char *nameString;
05097     int ret, dummy;
05098     int thr_crit_bup;
05099     volatile VALUE current_thread = rb_thread_current();
05100     struct timeval t;
05101 
05102     DUMP1("Ruby's 'thread_tkwait' is called");
05103     if (interp == (Tcl_Interp*)NULL) {
05104         rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
05105                                              "IP is deleted");
05106         return TCL_ERROR;
05107     }
05108 
05109     if (rb_thread_alone() || eventloop_thread == current_thread) {
05110 #if TCL_MAJOR_VERSION >= 8
05111         DUMP1("call ip_rbTkWaitObjCmd");
05112         DUMP2("eventloop_thread %lx", eventloop_thread);
05113         DUMP2("current_thread %lx", current_thread);
05114         return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
05115 #else /* TCL_MAJOR_VERSION < 8 */
05116         DUMP1("call rb_VwaitCommand");
05117         return ip_rbTkWaitCommand(clientData, interp, objc, objv);
05118 #endif
05119     }
05120 
05121     Tcl_Preserve(interp);
05122     Tcl_Preserve(tkwin);
05123 
05124     Tcl_ResetResult(interp);
05125 
05126     if (objc != 3) {
05127 #ifdef Tcl_WrongNumArgs
05128         Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
05129 #else
05130         thr_crit_bup = rb_thread_critical;
05131         rb_thread_critical = Qtrue;
05132 
05133 #if TCL_MAJOR_VERSION >= 8
05134         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05135                          Tcl_GetStringFromObj(objv[0], &dummy),
05136                          " variable|visibility|window name\"",
05137                          (char *) NULL);
05138 #else /* TCL_MAJOR_VERSION < 8 */
05139         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05140                          objv[0], " variable|visibility|window name\"",
05141                          (char *) NULL);
05142 #endif
05143 
05144         rb_thread_critical = thr_crit_bup;
05145 #endif
05146 
05147         Tcl_Release(tkwin);
05148         Tcl_Release(interp);
05149         return TCL_ERROR;
05150     }
05151 
05152 #if TCL_MAJOR_VERSION >= 8
05153     thr_crit_bup = rb_thread_critical;
05154     rb_thread_critical = Qtrue;
05155     /*
05156     if (Tcl_GetIndexFromObj(interp, objv[1],
05157                             (CONST84 char **)optionStrings,
05158                             "option", 0, &index) != TCL_OK) {
05159         return TCL_ERROR;
05160     }
05161     */
05162     ret = Tcl_GetIndexFromObj(interp, objv[1],
05163                               (CONST84 char **)optionStrings,
05164                               "option", 0, &index);
05165 
05166     rb_thread_critical = thr_crit_bup;
05167 
05168     if (ret != TCL_OK) {
05169         Tcl_Release(tkwin);
05170         Tcl_Release(interp);
05171         return TCL_ERROR;
05172     }
05173 #else /* TCL_MAJOR_VERSION < 8 */
05174     {
05175         int c = objv[1][0];
05176         size_t length = strlen(objv[1]);
05177 
05178         if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
05179             && (length >= 2)) {
05180             index = TKWAIT_VARIABLE;
05181         } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
05182                    && (length >= 2)) {
05183             index = TKWAIT_VISIBILITY;
05184         } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
05185             index = TKWAIT_WINDOW;
05186         } else {
05187             Tcl_AppendResult(interp, "bad option \"", objv[1],
05188                              "\": must be variable, visibility, or window",
05189                              (char *) NULL);
05190             Tcl_Release(tkwin);
05191             Tcl_Release(interp);
05192             return TCL_ERROR;
05193         }
05194     }
05195 #endif
05196 
05197     thr_crit_bup = rb_thread_critical;
05198     rb_thread_critical = Qtrue;
05199 
05200 #if TCL_MAJOR_VERSION >= 8
05201     Tcl_IncrRefCount(objv[2]);
05202     /* nameString = Tcl_GetString(objv[2]); */
05203     nameString = Tcl_GetStringFromObj(objv[2], &dummy);
05204 #else /* TCL_MAJOR_VERSION < 8 */
05205     nameString = objv[2];
05206 #endif
05207 
05208     /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
05209     param = RbTk_ALLOC_N(struct th_vwait_param, 1);
05210 #if 1 /* use Tcl_Preserve/Release */
05211     Tcl_Preserve((ClientData)param);
05212 #endif
05213     param->thread = current_thread;
05214     param->done = 0;
05215 
05216     rb_thread_critical = thr_crit_bup;
05217 
05218     switch ((enum options) index) {
05219     case TKWAIT_VARIABLE:
05220         thr_crit_bup = rb_thread_critical;
05221         rb_thread_critical = Qtrue;
05222         /*
05223         if (Tcl_TraceVar(interp, nameString,
05224                          TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05225                          rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
05226             return TCL_ERROR;
05227         }
05228         */
05229         ret = Tcl_TraceVar(interp, nameString,
05230                          TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05231                          rb_threadVwaitProc, (ClientData) param);
05232 
05233         rb_thread_critical = thr_crit_bup;
05234 
05235         if (ret != TCL_OK) {
05236 #if 0 /* use Tcl_EventuallyFree */
05237             Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05238 #else
05239 #if 1 /* use Tcl_Preserve/Release */
05240             Tcl_Release(param);
05241 #else
05242             /* Tcl_Free((char *)param); */
05243             ckfree((char *)param);
05244 #endif
05245 #endif
05246 
05247 #if TCL_MAJOR_VERSION >= 8
05248             Tcl_DecrRefCount(objv[2]);
05249 #endif
05250 
05251             Tcl_Release(tkwin);
05252             Tcl_Release(interp);
05253             return TCL_ERROR;
05254         }
05255 
05256         t.tv_sec  = 0;
05257         t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05258 
05259         while(!param->done) {
05260           /* rb_thread_stop(); */
05261           /* rb_thread_sleep_forever(); */
05262           rb_thread_wait_for(t);
05263           if (NIL_P(eventloop_thread)) {
05264             break;
05265           }
05266         }
05267 
05268         thr_crit_bup = rb_thread_critical;
05269         rb_thread_critical = Qtrue;
05270 
05271         if (param->done > 0) {
05272             Tcl_UntraceVar(interp, nameString,
05273                            TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05274                            rb_threadVwaitProc, (ClientData) param);
05275         }
05276 
05277 #if TCL_MAJOR_VERSION >= 8
05278         Tcl_DecrRefCount(objv[2]);
05279 #endif
05280 
05281         rb_thread_critical = thr_crit_bup;
05282 
05283         break;
05284 
05285     case TKWAIT_VISIBILITY:
05286         thr_crit_bup = rb_thread_critical;
05287         rb_thread_critical = Qtrue;
05288 
05289 #if 0 /* variable 'tkwin' must keep the token of MainWindow */
05290         if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
05291             window = NULL;
05292         } else {
05293             window = Tk_NameToWindow(interp, nameString, tkwin);
05294         }
05295 #else
05296         if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
05297             window = NULL;
05298         } else {
05299             /* Tk_NameToWindow() returns right token on non-eventloop thread */
05300             Tcl_CmdInfo info;
05301             if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
05302                 window = Tk_NameToWindow(interp, nameString, tkwin);
05303             } else {
05304                 window = NULL;
05305             }
05306         }
05307 #endif
05308 
05309         if (window == NULL) {
05310             Tcl_AppendResult(interp, ": thread_tkwait: ",
05311                              "no main-window (not Tk application?)",
05312                              (char*)NULL);
05313 
05314             rb_thread_critical = thr_crit_bup;
05315 
05316 #if 0 /* use Tcl_EventuallyFree */
05317             Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05318 #else
05319 #if 1 /* use Tcl_Preserve/Release */
05320             Tcl_Release(param);
05321 #else
05322             /* Tcl_Free((char *)param); */
05323             ckfree((char *)param);
05324 #endif
05325 #endif
05326 
05327 #if TCL_MAJOR_VERSION >= 8
05328             Tcl_DecrRefCount(objv[2]);
05329 #endif
05330             Tcl_Release(tkwin);
05331             Tcl_Release(interp);
05332             return TCL_ERROR;
05333         }
05334         Tcl_Preserve(window);
05335 
05336         Tk_CreateEventHandler(window,
05337                               VisibilityChangeMask|StructureNotifyMask,
05338                               rb_threadWaitVisibilityProc, (ClientData) param);
05339 
05340         rb_thread_critical = thr_crit_bup;
05341 
05342         t.tv_sec  = 0;
05343         t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05344 
05345         while(param->done != TKWAIT_MODE_VISIBILITY) {
05346           if (param->done == TKWAIT_MODE_DESTROY) break;
05347           /* rb_thread_stop(); */
05348           /* rb_thread_sleep_forever(); */
05349           rb_thread_wait_for(t);
05350           if (NIL_P(eventloop_thread)) {
05351             break;
05352           }
05353         }
05354 
05355         thr_crit_bup = rb_thread_critical;
05356         rb_thread_critical = Qtrue;
05357 
05358         /* when a window is destroyed, no need to call Tk_DeleteEventHandler */
05359         if (param->done != TKWAIT_MODE_DESTROY) {
05360             Tk_DeleteEventHandler(window,
05361                                   VisibilityChangeMask|StructureNotifyMask,
05362                                   rb_threadWaitVisibilityProc,
05363                                   (ClientData) param);
05364         }
05365 
05366         if (param->done != 1) {
05367             Tcl_ResetResult(interp);
05368             Tcl_AppendResult(interp, "window \"", nameString,
05369                              "\" was deleted before its visibility changed",
05370                              (char *) NULL);
05371 
05372             rb_thread_critical = thr_crit_bup;
05373 
05374             Tcl_Release(window);
05375 
05376 #if 0 /* use Tcl_EventuallyFree */
05377             Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05378 #else
05379 #if 1 /* use Tcl_Preserve/Release */
05380             Tcl_Release(param);
05381 #else
05382             /* Tcl_Free((char *)param); */
05383             ckfree((char *)param);
05384 #endif
05385 #endif
05386 
05387 #if TCL_MAJOR_VERSION >= 8
05388             Tcl_DecrRefCount(objv[2]);
05389 #endif
05390 
05391             Tcl_Release(tkwin);
05392             Tcl_Release(interp);
05393             return TCL_ERROR;
05394         }
05395 
05396         Tcl_Release(window);
05397 
05398 #if TCL_MAJOR_VERSION >= 8
05399         Tcl_DecrRefCount(objv[2]);
05400 #endif
05401 
05402         rb_thread_critical = thr_crit_bup;
05403 
05404         break;
05405 
05406     case TKWAIT_WINDOW:
05407         thr_crit_bup = rb_thread_critical;
05408         rb_thread_critical = Qtrue;
05409 
05410 #if 0 /* variable 'tkwin' must keep the token of MainWindow */
05411         if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
05412             window = NULL;
05413         } else {
05414             window = Tk_NameToWindow(interp, nameString, tkwin);
05415         }
05416 #else
05417         if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
05418             window = NULL;
05419         } else {
05420             /* Tk_NameToWindow() returns right token on non-eventloop thread */
05421             Tcl_CmdInfo info;
05422             if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
05423                 window = Tk_NameToWindow(interp, nameString, tkwin);
05424             } else {
05425                 window = NULL;
05426             }
05427         }
05428 #endif
05429 
05430 #if TCL_MAJOR_VERSION >= 8
05431         Tcl_DecrRefCount(objv[2]);
05432 #endif
05433 
05434         if (window == NULL) {
05435             Tcl_AppendResult(interp, ": thread_tkwait: ",
05436                              "no main-window (not Tk application?)",
05437                              (char*)NULL);
05438 
05439             rb_thread_critical = thr_crit_bup;
05440 
05441 #if 0 /* use Tcl_EventuallyFree */
05442             Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05443 #else
05444 #if 1 /* use Tcl_Preserve/Release */
05445             Tcl_Release(param);
05446 #else
05447             /* Tcl_Free((char *)param); */
05448             ckfree((char *)param);
05449 #endif
05450 #endif
05451 
05452             Tcl_Release(tkwin);
05453             Tcl_Release(interp);
05454             return TCL_ERROR;
05455         }
05456 
05457         Tcl_Preserve(window);
05458 
05459         Tk_CreateEventHandler(window, StructureNotifyMask,
05460                               rb_threadWaitWindowProc, (ClientData) param);
05461 
05462         rb_thread_critical = thr_crit_bup;
05463 
05464         t.tv_sec  = 0;
05465         t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05466 
05467         while(param->done != TKWAIT_MODE_DESTROY) {
05468           /* rb_thread_stop(); */
05469           /* rb_thread_sleep_forever(); */
05470           rb_thread_wait_for(t);
05471           if (NIL_P(eventloop_thread)) {
05472             break;
05473           }
05474         }
05475 
05476         Tcl_Release(window);
05477 
05478         /* when a window is destroyed, no need to call Tk_DeleteEventHandler
05479         thr_crit_bup = rb_thread_critical;
05480         rb_thread_critical = Qtrue;
05481 
05482         Tk_DeleteEventHandler(window, StructureNotifyMask,
05483                               rb_threadWaitWindowProc, (ClientData) param);
05484 
05485         rb_thread_critical = thr_crit_bup;
05486         */
05487 
05488         break;
05489     } /* end of 'switch' statement */
05490 
05491 #if 0 /* use Tcl_EventuallyFree */
05492     Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
05493 #else
05494 #if 1 /* use Tcl_Preserve/Release */
05495     Tcl_Release((ClientData)param);
05496 #else
05497     /* Tcl_Free((char *)param); */
05498     ckfree((char *)param);
05499 #endif
05500 #endif
05501 
05502     /*
05503      * Clear out the interpreter's result, since it may have been set
05504      * by event handlers.
05505      */
05506 
05507     Tcl_ResetResult(interp);
05508 
05509     Tcl_Release(tkwin);
05510     Tcl_Release(interp);
05511     return TCL_OK;
05512 }
05513 
05514 static VALUE
05515 ip_thread_vwait(self, var)
05516     VALUE self;
05517     VALUE var;
05518 {
05519     VALUE argv[2];
05520     volatile VALUE cmd_str = rb_str_new2("thread_vwait");
05521 
05522     argv[0] = cmd_str;
05523     argv[1] = var;
05524 
05525     return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL);
05526 }
05527 
05528 static VALUE
05529 ip_thread_tkwait(self, mode, target)
05530     VALUE self;
05531     VALUE mode;
05532     VALUE target;
05533 {
05534     VALUE argv[3];
05535     volatile VALUE cmd_str = rb_str_new2("thread_tkwait");
05536 
05537     argv[0] = cmd_str;
05538     argv[1] = mode;
05539     argv[2] = target;
05540 
05541     return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL);
05542 }
05543 
05544 
05545 /* delete slave interpreters */
05546 #if TCL_MAJOR_VERSION >= 8
05547 static void
05548 delete_slaves(ip)
05549     Tcl_Interp *ip;
05550 {
05551     int  thr_crit_bup;
05552     Tcl_Interp *slave;
05553     Tcl_Obj *slave_list, *elem;
05554     char *slave_name;
05555     int i, len;
05556 
05557     DUMP1("delete slaves");
05558     thr_crit_bup = rb_thread_critical;
05559     rb_thread_critical = Qtrue;
05560 
05561     if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
05562         slave_list = Tcl_GetObjResult(ip);
05563         Tcl_IncrRefCount(slave_list);
05564 
05565         if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) {
05566             for(i = 0; i < len; i++) {
05567                 Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem);
05568 
05569                 if (elem == (Tcl_Obj*)NULL) continue;
05570 
05571                 Tcl_IncrRefCount(elem);
05572 
05573                 /* get slave */
05574                 /* slave_name = Tcl_GetString(elem); */
05575                 slave_name = Tcl_GetStringFromObj(elem, (int*)NULL);
05576                 DUMP2("delete slave:'%s'", slave_name);
05577 
05578                 Tcl_DecrRefCount(elem);
05579 
05580                 slave = Tcl_GetSlave(ip, slave_name);
05581                 if (slave == (Tcl_Interp*)NULL) continue;
05582 
05583                 if (!Tcl_InterpDeleted(slave)) {
05584                   /* call ip_finalize */
05585                   ip_finalize(slave);
05586 
05587                   Tcl_DeleteInterp(slave);
05588                   /* Tcl_Release(slave); */
05589                 }
05590             }
05591         }
05592 
05593         Tcl_DecrRefCount(slave_list);
05594     }
05595 
05596     rb_thread_critical = thr_crit_bup;
05597 }
05598 #else /* TCL_MAJOR_VERSION < 8 */
05599 static void
05600 delete_slaves(ip)
05601     Tcl_Interp *ip;
05602 {
05603     int  thr_crit_bup;
05604     Tcl_Interp *slave;
05605     int argc;
05606     char **argv;
05607     char *slave_list;
05608     char *slave_name;
05609     int i, len;
05610 
05611     DUMP1("delete slaves");
05612     thr_crit_bup = rb_thread_critical;
05613     rb_thread_critical = Qtrue;
05614 
05615     if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
05616         slave_list = ip->result;
05617         if (Tcl_SplitList((Tcl_Interp*)NULL,
05618                           slave_list, &argc, &argv) == TCL_OK) {
05619             for(i = 0; i < argc; i++) {
05620                 slave_name = argv[i];
05621 
05622                 DUMP2("delete slave:'%s'", slave_name);
05623 
05624                 slave = Tcl_GetSlave(ip, slave_name);
05625                 if (slave == (Tcl_Interp*)NULL) continue;
05626 
05627                 if (!Tcl_InterpDeleted(slave)) {
05628                   /* call ip_finalize */
05629                   ip_finalize(slave);
05630 
05631                   Tcl_DeleteInterp(slave);
05632                 }
05633             }
05634         }
05635     }
05636 
05637     rb_thread_critical = thr_crit_bup;
05638 }
05639 #endif
05640 
05641 
05642 /* finalize operation */
05643 static void
05644 #ifdef HAVE_PROTOTYPES
05645 lib_mark_at_exit(VALUE self)
05646 #else
05647 lib_mark_at_exit(self)
05648     VALUE self;
05649 #endif
05650 {
05651     at_exit = 1;
05652 }
05653 
05654 static int
05655 #if TCL_MAJOR_VERSION >= 8
05656 #ifdef HAVE_PROTOTYPES
05657 ip_null_proc(ClientData clientData, Tcl_Interp *interp,
05658              int argc, Tcl_Obj *CONST argv[])
05659 #else
05660 ip_null_proc(clientData, interp, argc, argv)
05661     ClientData clientData;
05662     Tcl_Interp *interp;
05663     int argc;
05664     Tcl_Obj *CONST argv[];
05665 #endif
05666 #else /* TCL_MAJOR_VERSION < 8 */
05667 #ifdef HAVE_PROTOTYPES
05668 ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
05669 #else
05670 ip_null_proc(clientData, interp, argc, argv)
05671     ClientData clientData;
05672     Tcl_Interp *interp;
05673     int argc;
05674     char *argv[];
05675 #endif
05676 #endif
05677 {
05678     Tcl_ResetResult(interp);
05679     return TCL_OK;
05680 }
05681 
05682 static void
05683 ip_finalize(ip)
05684     Tcl_Interp *ip;
05685 {
05686     Tcl_CmdInfo info;
05687     int  thr_crit_bup;
05688 
05689     VALUE rb_debug_bup, rb_verbose_bup;
05690           /* When ruby is exiting, printing debug messages in some callback
05691              operations from Tcl-IP sometimes cause SEGV. I don't know the
05692              reason. But I got SEGV when calling "rb_io_write(rb_stdout, ...)".
05693              So, in some part of this function, debug mode and verbose mode
05694              are disabled. If you know the reason, please fix it.
05695                            --  Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)  */
05696 
05697     DUMP1("start ip_finalize");
05698 
05699     if (ip == (Tcl_Interp*)NULL) {
05700         DUMP1("ip is NULL");
05701         return;
05702     }
05703 
05704     if (Tcl_InterpDeleted(ip)) {
05705         DUMP2("ip(%p) is already deleted", ip);
05706         return;
05707     }
05708 
05709 #if TCL_NAMESPACE_DEBUG
05710     if (ip_null_namespace(ip)) {
05711         DUMP2("ip(%p) has null namespace", ip);
05712         return;
05713     }
05714 #endif
05715 
05716     thr_crit_bup = rb_thread_critical;
05717     rb_thread_critical = Qtrue;
05718 
05719     rb_debug_bup   = ruby_debug;
05720     rb_verbose_bup = ruby_verbose;
05721 
05722     Tcl_Preserve(ip);
05723 
05724     /* delete slaves */
05725     delete_slaves(ip);
05726 
05727     /* shut off some connections from Tcl-proc to Ruby */
05728     if (at_exit) {
05729         /* NOTE: Only when at exit.
05730            Because, ruby removes objects, which depends on the deleted
05731            interpreter, on some callback operations.
05732            It is important for GC. */
05733 #if TCL_MAJOR_VERSION >= 8
05734         Tcl_CreateObjCommand(ip, "ruby", ip_null_proc,
05735                              (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05736         Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc,
05737                              (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05738         Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc,
05739                              (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05740 #else /* TCL_MAJOR_VERSION < 8 */
05741         Tcl_CreateCommand(ip, "ruby", ip_null_proc,
05742                           (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05743         Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc,
05744                           (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05745         Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc,
05746                           (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05747 #endif
05748         /*
05749           rb_thread_critical = thr_crit_bup;
05750           return;
05751         */
05752     }
05753 
05754     /* delete root widget */
05755 #ifdef RUBY_VM
05756     /* cause SEGV on Ruby 1.9 */
05757 #else
05758     DUMP1("check `destroy'");
05759     if (Tcl_GetCommandInfo(ip, "destroy", &info)) {
05760         DUMP1("call `destroy .'");
05761         Tcl_GlobalEval(ip, "catch {destroy .}");
05762     }
05763 #endif
05764 #if 1
05765     DUMP1("destroy root widget");
05766     if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) {
05767         /*
05768          *  On Ruby VM, this code piece may be not called, because
05769          *  Tk_MainWindow() returns NULL on a native thread except
05770          *  the thread which initialize Tk environment.
05771          *  Of course, that is a problem. But maybe not so serious.
05772          *  All widgets are destroyed when the Tcl interp is deleted.
05773          *  At then, Ruby may raise exceptions on the delete hook
05774          *  callbacks which registered for the deleted widgets, and
05775          *  may fail to clear objects which depends on the widgets.
05776          *  Although it is the problem, it is possibly avoidable by
05777          *  rescuing exceptions and the finalize hook of the interp.
05778          */
05779         Tk_Window win = Tk_MainWindow(ip);
05780 
05781         DUMP1("call Tk_DestroyWindow");
05782         ruby_debug   = Qfalse;
05783         ruby_verbose = Qnil;
05784         if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) {
05785           Tk_DestroyWindow(win);
05786         }
05787         ruby_debug   = rb_debug_bup;
05788         ruby_verbose = rb_verbose_bup;
05789     }
05790 #endif
05791 
05792     /* call finalize-hook-proc */
05793     DUMP1("check `finalize-hook-proc'");
05794     if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
05795         DUMP2("call finalize hook proc '%s'", finalize_hook_name);
05796         ruby_debug   = Qfalse;
05797         ruby_verbose = Qnil;
05798         Tcl_GlobalEval(ip, finalize_hook_name);
05799         ruby_debug   = rb_debug_bup;
05800         ruby_verbose = rb_verbose_bup;
05801     }
05802 
05803     DUMP1("check `foreach' & `after'");
05804     if ( Tcl_GetCommandInfo(ip, "foreach", &info)
05805          && Tcl_GetCommandInfo(ip, "after", &info) ) {
05806         DUMP1("cancel after callbacks");
05807         ruby_debug   = Qfalse;
05808         ruby_verbose = Qnil;
05809         Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}");
05810         ruby_debug   = rb_debug_bup;
05811         ruby_verbose = rb_verbose_bup;
05812     }
05813 
05814     Tcl_Release(ip);
05815 
05816     DUMP1("finish ip_finalize");
05817     ruby_debug   = rb_debug_bup;
05818     ruby_verbose = rb_verbose_bup;
05819     rb_thread_critical = thr_crit_bup;
05820 }
05821 
05822 
05823 /* destroy interpreter */
05824 static void
05825 ip_free(ptr)
05826     struct tcltkip *ptr;
05827 {
05828     int  thr_crit_bup;
05829 
05830     DUMP2("free Tcl Interp %lx", (unsigned long)ptr->ip);
05831     if (ptr) {
05832         thr_crit_bup = rb_thread_critical;
05833         rb_thread_critical = Qtrue;
05834 
05835         if ( ptr->ip != (Tcl_Interp*)NULL
05836              && !Tcl_InterpDeleted(ptr->ip)
05837              && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL
05838              && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) {
05839             DUMP2("parent IP(%lx) is not deleted",
05840                   (unsigned long)Tcl_GetMaster(ptr->ip));
05841             DUMP2("slave IP(%lx) should not be deleted",
05842                   (unsigned long)ptr->ip);
05843             xfree(ptr);
05844             /* ckfree((char*)ptr); */
05845             rb_thread_critical = thr_crit_bup;
05846             return;
05847         }
05848 
05849         if (ptr->ip == (Tcl_Interp*)NULL) {
05850             DUMP1("ip_free is called for deleted IP");
05851             xfree(ptr);
05852             /* ckfree((char*)ptr); */
05853             rb_thread_critical = thr_crit_bup;
05854             return;
05855         }
05856 
05857         if (!Tcl_InterpDeleted(ptr->ip)) {
05858           ip_finalize(ptr->ip);
05859 
05860           Tcl_DeleteInterp(ptr->ip);
05861           Tcl_Release(ptr->ip);
05862         }
05863 
05864         ptr->ip = (Tcl_Interp*)NULL;
05865         xfree(ptr);
05866         /* ckfree((char*)ptr); */
05867 
05868         rb_thread_critical = thr_crit_bup;
05869     }
05870 
05871     DUMP1("complete freeing Tcl Interp");
05872 }
05873 
05874 
05875 /* create and initialize interpreter */
05876 static VALUE ip_alloc _((VALUE));
05877 static VALUE
05878 ip_alloc(self)
05879     VALUE self;
05880 {
05881     return Data_Wrap_Struct(self, 0, ip_free, 0);
05882 }
05883 
05884 static void
05885 ip_replace_wait_commands(interp, mainWin)
05886     Tcl_Interp *interp;
05887     Tk_Window mainWin;
05888 {
05889     /* replace 'vwait' command */
05890 #if TCL_MAJOR_VERSION >= 8
05891     DUMP1("Tcl_CreateObjCommand(\"vwait\")");
05892     Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd,
05893                          (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05894 #else /* TCL_MAJOR_VERSION < 8 */
05895     DUMP1("Tcl_CreateCommand(\"vwait\")");
05896     Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand,
05897                       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05898 #endif
05899 
05900     /* replace 'tkwait' command */
05901 #if TCL_MAJOR_VERSION >= 8
05902     DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
05903     Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd,
05904                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05905 #else /* TCL_MAJOR_VERSION < 8 */
05906     DUMP1("Tcl_CreateCommand(\"tkwait\")");
05907     Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand,
05908                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05909 #endif
05910 
05911     /* add 'thread_vwait' command */
05912 #if TCL_MAJOR_VERSION >= 8
05913     DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
05914     Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd,
05915                          (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05916 #else /* TCL_MAJOR_VERSION < 8 */
05917     DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
05918     Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand,
05919                       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05920 #endif
05921 
05922     /* add 'thread_tkwait' command */
05923 #if TCL_MAJOR_VERSION >= 8
05924     DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
05925     Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
05926                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05927 #else /* TCL_MAJOR_VERSION < 8 */
05928     DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
05929     Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand,
05930                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05931 #endif
05932 
05933     /* replace 'update' command */
05934 #if TCL_MAJOR_VERSION >= 8
05935     DUMP1("Tcl_CreateObjCommand(\"update\")");
05936     Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd,
05937                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05938 #else /* TCL_MAJOR_VERSION < 8 */
05939     DUMP1("Tcl_CreateCommand(\"update\")");
05940     Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand,
05941                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05942 #endif
05943 
05944     /* add 'thread_update' command */
05945 #if TCL_MAJOR_VERSION >= 8
05946     DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
05947     Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd,
05948                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05949 #else /* TCL_MAJOR_VERSION < 8 */
05950     DUMP1("Tcl_CreateCommand(\"thread_update\")");
05951     Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand,
05952                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05953 #endif
05954 }
05955 
05956 
05957 #if TCL_MAJOR_VERSION >= 8
05958 static int
05959 ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv)
05960     ClientData clientData;
05961     Tcl_Interp *interp;
05962     int objc;
05963     Tcl_Obj *CONST objv[];
05964 #else /* TCL_MAJOR_VERSION < 8 */
05965 static int
05966 ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv)
05967     ClientData clientData;
05968     Tcl_Interp *interp;
05969     int objc;
05970     char *objv[];
05971 #endif
05972 {
05973     char *slave_name;
05974     Tcl_Interp *slave;
05975     Tk_Window mainWin;
05976 
05977     if (objc != 2) {
05978 #ifdef Tcl_WrongNumArgs
05979         Tcl_WrongNumArgs(interp, 1, objv, "slave_name");
05980 #else
05981         char *nameString;
05982 #if TCL_MAJOR_VERSION >= 8
05983         nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL);
05984 #else /* TCL_MAJOR_VERSION < 8 */
05985         nameString = objv[0];
05986 #endif
05987         Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05988                          nameString, " slave_name\"", (char *) NULL);
05989 #endif
05990     }
05991 
05992 #if TCL_MAJOR_VERSION >= 8
05993     slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
05994 #else
05995     slave_name = objv[1];
05996 #endif
05997 
05998     slave = Tcl_GetSlave(interp, slave_name);
05999     if (slave == NULL) {
06000         Tcl_AppendResult(interp, "cannot find slave \"",
06001                          slave_name, "\"", (char *)NULL);
06002         return TCL_ERROR;
06003     }
06004     mainWin = Tk_MainWindow(slave);
06005 
06006     /* replace 'exit' command --> 'interp_exit' command */
06007 #if TCL_MAJOR_VERSION >= 8
06008     DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06009     Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd,
06010                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06011 #else /* TCL_MAJOR_VERSION < 8 */
06012     DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06013     Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand,
06014                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06015 #endif
06016 
06017     /* replace vwait and tkwait */
06018     ip_replace_wait_commands(slave, mainWin);
06019 
06020     return TCL_OK;
06021 }
06022 
06023 
06024 #if TCL_MAJOR_VERSION >= 8
06025 static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int,
06026                                    Tcl_Obj *CONST []));
06027 static int
06028 ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
06029     ClientData clientData;
06030     Tcl_Interp *interp;
06031     int objc;
06032     Tcl_Obj *CONST objv[];
06033 {
06034     Tcl_CmdInfo info;
06035     int ret;
06036 
06037     if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) {
06038         Tcl_ResetResult(interp);
06039         Tcl_AppendResult(interp,
06040                          "invalid command name \"namespace\"", (char*)NULL);
06041         return TCL_ERROR;
06042     }
06043 
06044     rbtk_eventloop_depth++;
06045     /* DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); */
06046 
06047     if (info.isNativeObjectProc) {
06048         ret = (*(info.objProc))(info.objClientData, interp, objc, objv);
06049     } else {
06050         /* string interface */
06051         int i;
06052         char **argv;
06053 
06054         /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */
06055         argv = RbTk_ALLOC_N(char *, (objc + 1));
06056 #if 0 /* use Tcl_Preserve/Release */
06057         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
06058 #endif
06059 
06060         for(i = 0; i < objc; i++) {
06061             /* argv[i] = Tcl_GetString(objv[i]); */
06062             argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
06063         }
06064         argv[objc] = (char *)NULL;
06065 
06066         ret = (*(info.proc))(info.clientData, interp,
06067                               objc, (CONST84 char **)argv);
06068 
06069 #if 0 /* use Tcl_EventuallyFree */
06070         Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
06071 #else
06072 #if 0 /* use Tcl_Preserve/Release */
06073         Tcl_Release((ClientData)argv); /* XXXXXXXX */
06074 #else
06075         /* Tcl_Free((char*)argv); */
06076         ckfree((char*)argv);
06077 #endif
06078 #endif
06079     }
06080 
06081     /* DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); */
06082     rbtk_eventloop_depth--;
06083 
06084     return ret;
06085 }
06086 #endif
06087 
06088 static void
06089 ip_wrap_namespace_command(interp)
06090     Tcl_Interp *interp;
06091 {
06092 #if TCL_MAJOR_VERSION >= 8
06093     Tcl_CmdInfo orig_info;
06094 
06095     if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) {
06096         return;
06097     }
06098 
06099     if (orig_info.isNativeObjectProc) {
06100         Tcl_CreateObjCommand(interp, "__orig_namespace_command__",
06101                              orig_info.objProc, orig_info.objClientData,
06102                              orig_info.deleteProc);
06103     } else {
06104         Tcl_CreateCommand(interp, "__orig_namespace_command__",
06105                           orig_info.proc, orig_info.clientData,
06106                           orig_info.deleteProc);
06107     }
06108 
06109     Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
06110                          (ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
06111 #endif
06112 }
06113 
06114 
06115 /* call when interpreter is deleted */
06116 static void
06117 #ifdef HAVE_PROTOTYPES
06118 ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip)
06119 #else
06120 ip_CallWhenDeleted(clientData, ip)
06121     ClientData clientData;
06122     Tcl_Interp *ip;
06123 #endif
06124 {
06125     int  thr_crit_bup;
06126     /* Tk_Window main_win = (Tk_Window) clientData; */
06127 
06128     DUMP1("start ip_CallWhenDeleted");
06129     thr_crit_bup = rb_thread_critical;
06130     rb_thread_critical = Qtrue;
06131 
06132     ip_finalize(ip);
06133 
06134     DUMP1("finish ip_CallWhenDeleted");
06135     rb_thread_critical = thr_crit_bup;
06136 }
06137 
06138 /*--------------------------------------------------------*/
06139 
06140 /* initialize interpreter */
06141 static VALUE
06142 ip_init(argc, argv, self)
06143     int   argc;
06144     VALUE *argv;
06145     VALUE self;
06146 {
06147     struct tcltkip *ptr;        /* tcltkip data struct */
06148     VALUE argv0, opts;
06149     int cnt;
06150     int st;
06151     int with_tk = 1;
06152     Tk_Window mainWin = (Tk_Window)NULL;
06153 
06154     /* security check */
06155     if (rb_safe_level() >= 4) {
06156         rb_raise(rb_eSecurityError,
06157                  "Cannot create a TclTkIp object at level %d",
06158                  rb_safe_level());
06159     }
06160 
06161     /* create object */
06162     Data_Get_Struct(self, struct tcltkip, ptr);
06163     ptr = ALLOC(struct tcltkip);
06164     /* ptr = RbTk_ALLOC_N(struct tcltkip, 1); */
06165     DATA_PTR(self) = ptr;
06166 #ifdef RUBY_USE_NATIVE_THREAD
06167     ptr->tk_thread_id = 0;
06168 #endif
06169     ptr->ref_count = 0;
06170     ptr->allow_ruby_exit = 1;
06171     ptr->return_value = 0;
06172 
06173     /* from Tk_Main() */
06174     DUMP1("Tcl_CreateInterp");
06175     ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st);
06176     if (ptr->ip == NULL) {
06177         switch(st) {
06178         case TCLTK_STUBS_OK:
06179             break;
06180         case NO_TCL_DLL:
06181             rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
06182         case NO_FindExecutable:
06183             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
06184         case NO_CreateInterp:
06185             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
06186         case NO_DeleteInterp:
06187             rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
06188         case FAIL_CreateInterp:
06189             rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP");
06190         case FAIL_Tcl_InitStubs:
06191             rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
06192         default:
06193             rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st);
06194         }
06195     }
06196 
06197 #if TCL_MAJOR_VERSION >= 8
06198 #if TCL_NAMESPACE_DEBUG
06199     DUMP1("get current namespace");
06200     if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip))
06201         == (Tcl_Namespace*)NULL) {
06202       rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace");
06203     }
06204 #endif
06205 #endif
06206 
06207     rbtk_preserve_ip(ptr);
06208     DUMP2("IP ref_count = %d", ptr->ref_count);
06209     current_interp = ptr->ip;
06210 
06211     ptr->has_orig_exit
06212         = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info));
06213 
06214 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
06215     call_tclkit_init_script(current_interp);
06216 
06217 # if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
06218     {
06219       Tcl_DString encodingName;
06220       Tcl_GetEncodingNameFromEnvironment(&encodingName);
06221       if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
06222         /* fails, so we set a variable and do it in the boot.tcl script */
06223         Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
06224       }
06225       Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
06226       Tcl_DStringFree(&encodingName);
06227     }
06228 # endif
06229 #endif
06230 
06231     /* set variables */
06232     Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so");
06233 
06234     cnt = rb_scan_args(argc, argv, "02", &argv0, &opts);
06235     switch(cnt) {
06236     case 2:
06237         /* options */
06238         if (NIL_P(opts) || opts == Qfalse) {
06239             /* without Tk */
06240             with_tk = 0;
06241         } else {
06242             /* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */
06243             Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY);
06244             Tcl_Eval(ptr->ip, "set argc [llength $argv]");
06245         }
06246     case 1:
06247         /* argv0 */
06248         if (!NIL_P(argv0)) {
06249             if (strncmp(StringValuePtr(argv0), "-e", 3) == 0
06250                 || strncmp(StringValuePtr(argv0), "-", 2) == 0) {
06251                 Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY);
06252             } else {
06253                 /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */
06254                 Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0),
06255                            TCL_GLOBAL_ONLY);
06256             }
06257         }
06258     case 0:
06259         /* no args */
06260         ;
06261     }
06262 
06263     /* from Tcl_AppInit() */
06264     DUMP1("Tcl_Init");
06265 #if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85)
06266     /*************************************************************************/
06267     /*  FIX ME (2010/06/28)                                                  */
06268     /*    Don't use ::chan command for Mk4tcl + tclvfs-1.4 on Tcl8.5.        */
06269     /*    It fails to access VFS files because of vfs::zstream.              */
06270     /*    So, force to use ::rechan by temporaly hiding ::chan.              */
06271     /*************************************************************************/
06272     Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}");
06273     if (Tcl_Init(ptr->ip) == TCL_ERROR) {
06274         rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
06275     }
06276     Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}");
06277 #else
06278     if (Tcl_Init(ptr->ip) == TCL_ERROR) {
06279         rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
06280     }
06281 #endif
06282 
06283     st = ruby_tcl_stubs_init();
06284     /* from Tcl_AppInit() */
06285     if (with_tk) {
06286         DUMP1("Tk_Init");
06287         st = ruby_tk_stubs_init(ptr->ip);
06288         switch(st) {
06289         case TCLTK_STUBS_OK:
06290             break;
06291         case NO_Tk_Init:
06292             rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()");
06293         case FAIL_Tk_Init:
06294             rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s",
06295                      Tcl_GetStringResult(ptr->ip));
06296         case FAIL_Tk_InitStubs:
06297             rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s",
06298                      Tcl_GetStringResult(ptr->ip));
06299         default:
06300             rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
06301         }
06302 
06303         DUMP1("Tcl_StaticPackage(\"Tk\")");
06304 #if TCL_MAJOR_VERSION >= 8
06305         Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
06306 #else /* TCL_MAJOR_VERSION < 8 */
06307         Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
06308                           (Tcl_PackageInitProc *) NULL);
06309 #endif
06310 
06311 #ifdef RUBY_USE_NATIVE_THREAD
06312         /* set Tk thread ID */
06313         ptr->tk_thread_id = Tcl_GetCurrentThread();
06314 #endif
06315         /* get main window */
06316         mainWin = Tk_MainWindow(ptr->ip);
06317         Tk_Preserve((ClientData)mainWin);
06318     }
06319 
06320     /* add ruby command to the interpreter */
06321 #if TCL_MAJOR_VERSION >= 8
06322     DUMP1("Tcl_CreateObjCommand(\"ruby\")");
06323     Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
06324                          (Tcl_CmdDeleteProc *)NULL);
06325     DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")");
06326     Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
06327                          (Tcl_CmdDeleteProc *)NULL);
06328     DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")");
06329     Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
06330                          (Tcl_CmdDeleteProc *)NULL);
06331 #else /* TCL_MAJOR_VERSION < 8 */
06332     DUMP1("Tcl_CreateCommand(\"ruby\")");
06333     Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
06334                       (Tcl_CmdDeleteProc *)NULL);
06335     DUMP1("Tcl_CreateCommand(\"ruby_eval\")");
06336     Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
06337                       (Tcl_CmdDeleteProc *)NULL);
06338     DUMP1("Tcl_CreateCommand(\"ruby_cmd\")");
06339     Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
06340                       (Tcl_CmdDeleteProc *)NULL);
06341 #endif
06342 
06343     /* add 'interp_exit', 'ruby_exit' and replace 'exit' command */
06344 #if TCL_MAJOR_VERSION >= 8
06345     DUMP1("Tcl_CreateObjCommand(\"interp_exit\")");
06346     Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd,
06347                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06348     DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")");
06349     Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd,
06350                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06351     DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
06352     Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
06353                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06354 #else /* TCL_MAJOR_VERSION < 8 */
06355     DUMP1("Tcl_CreateCommand(\"interp_exit\")");
06356     Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand,
06357                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06358     DUMP1("Tcl_CreateCommand(\"ruby_exit\")");
06359     Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand,
06360                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06361     DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
06362     Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
06363                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06364 #endif
06365 
06366     /* replace vwait and tkwait */
06367     ip_replace_wait_commands(ptr->ip, mainWin);
06368 
06369     /* wrap namespace command */
06370     ip_wrap_namespace_command(ptr->ip);
06371 
06372     /* define command to replace commands which depend on slave's MainWindow */
06373 #if TCL_MAJOR_VERSION >= 8
06374     Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__",
06375                          ip_rb_replaceSlaveTkCmdsObjCmd,
06376                          (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06377 #else /* TCL_MAJOR_VERSION < 8 */
06378     Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__",
06379                       ip_rb_replaceSlaveTkCmdsCommand,
06380                       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06381 #endif
06382 
06383     /* set finalizer */
06384     Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin);
06385 
06386     if (mainWin != (Tk_Window)NULL) {
06387         Tk_Release((ClientData)mainWin);
06388     }
06389 
06390     return self;
06391 }
06392 
06393 static VALUE
06394 ip_create_slave_core(interp, argc, argv)
06395     VALUE interp;
06396     int   argc;
06397     VALUE *argv;
06398 {
06399     struct tcltkip *master = get_ip(interp);
06400     struct tcltkip *slave = ALLOC(struct tcltkip);
06401     /* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */
06402     VALUE safemode;
06403     VALUE name;
06404     int safe;
06405     int thr_crit_bup;
06406     Tk_Window mainWin;
06407 
06408     /* ip is deleted? */
06409     if (deleted_ip(master)) {
06410         return rb_exc_new2(rb_eRuntimeError,
06411                            "deleted master cannot create a new slave");
06412     }
06413 
06414     name     = argv[0];
06415     safemode = argv[1];
06416 
06417     if (Tcl_IsSafe(master->ip) == 1) {
06418         safe = 1;
06419     } else if (safemode == Qfalse || NIL_P(safemode)) {
06420         safe = 0;
06421         /* rb_secure(4); */ /* already checked */
06422     } else {
06423         safe = 1;
06424     }
06425 
06426     thr_crit_bup = rb_thread_critical;
06427     rb_thread_critical = Qtrue;
06428 
06429 #if 0
06430     /* init Tk */
06431     if (RTEST(with_tk)) {
06432         volatile VALUE exc;
06433         if (!tk_stubs_init_p()) {
06434             exc = tcltkip_init_tk(interp);
06435             if (!NIL_P(exc)) {
06436                 rb_thread_critical = thr_crit_bup;
06437                 return exc;
06438             }
06439         }
06440     }
06441 #endif
06442 
06443     /* create slave-ip */
06444 #ifdef RUBY_USE_NATIVE_THREAD
06445     /* slave->tk_thread_id = 0; */
06446     slave->tk_thread_id = master->tk_thread_id; /* == current thread */
06447 #endif
06448     slave->ref_count = 0;
06449     slave->allow_ruby_exit = 0;
06450     slave->return_value = 0;
06451 
06452     slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
06453     if (slave->ip == NULL) {
06454         rb_thread_critical = thr_crit_bup;
06455         return rb_exc_new2(rb_eRuntimeError,
06456                            "fail to create the new slave interpreter");
06457     }
06458 #if TCL_MAJOR_VERSION >= 8
06459 #if TCL_NAMESPACE_DEBUG
06460     slave->default_ns = Tcl_GetCurrentNamespace(slave->ip);
06461 #endif
06462 #endif
06463     rbtk_preserve_ip(slave);
06464 
06465     slave->has_orig_exit
06466         = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info));
06467 
06468     /* replace 'exit' command --> 'interp_exit' command */
06469     mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL;
06470 #if TCL_MAJOR_VERSION >= 8
06471     DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06472     Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd,
06473                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06474 #else /* TCL_MAJOR_VERSION < 8 */
06475     DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06476     Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand,
06477                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06478 #endif
06479 
06480     /* replace vwait and tkwait */
06481     ip_replace_wait_commands(slave->ip, mainWin);
06482 
06483     /* wrap namespace command */
06484     ip_wrap_namespace_command(slave->ip);
06485 
06486     /* define command to replace cmds which depend on slave-slave's MainWin */
06487 #if TCL_MAJOR_VERSION >= 8
06488     Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__",
06489                          ip_rb_replaceSlaveTkCmdsObjCmd,
06490                          (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06491 #else /* TCL_MAJOR_VERSION < 8 */
06492     Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__",
06493                       ip_rb_replaceSlaveTkCmdsCommand,
06494                       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06495 #endif
06496 
06497     /* set finalizer */
06498     Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin);
06499 
06500     rb_thread_critical = thr_crit_bup;
06501 
06502     return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave);
06503 }
06504 
06505 static VALUE
06506 ip_create_slave(argc, argv, self)
06507     int   argc;
06508     VALUE *argv;
06509     VALUE self;
06510 {
06511     struct tcltkip *master = get_ip(self);
06512     VALUE safemode;
06513     VALUE name;
06514     VALUE callargv[2];
06515 
06516     /* ip is deleted? */
06517     if (deleted_ip(master)) {
06518         rb_raise(rb_eRuntimeError,
06519                  "deleted master cannot create a new slave interpreter");
06520     }
06521 
06522     /* argument check */
06523     if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
06524         safemode = Qfalse;
06525     }
06526     if (Tcl_IsSafe(master->ip) != 1
06527         && (safemode == Qfalse || NIL_P(safemode))) {
06528         rb_secure(4);
06529     }
06530 
06531     StringValue(name);
06532     callargv[0] = name;
06533     callargv[1] = safemode;
06534 
06535     return tk_funcall(ip_create_slave_core, 2, callargv, self);
06536 }
06537 
06538 
06539 /* self is slave of master? */
06540 static VALUE
06541 ip_is_slave_of_p(self, master)
06542     VALUE self, master;
06543 {
06544     if (!rb_obj_is_kind_of(master, tcltkip_class)) {
06545         rb_raise(rb_eArgError, "expected TclTkIp object");
06546     }
06547 
06548     if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) {
06549       return Qtrue;
06550     } else {
06551       return Qfalse;
06552     }
06553 }
06554 
06555 
06556 /* create console (if supported) */
06557 #if defined(MAC_TCL) || defined(__WIN32__)
06558 #if TCL_MAJOR_VERSION < 8 \
06559     || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \
06560     || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06561         && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \
06562            || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
06563                && TCL_RELEASE_SERIAL < 2) ) )
06564 EXTERN void TkConsoleCreate _((void));
06565 #endif
06566 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06567     && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
06568           && TCL_RELEASE_SERIAL == 0) \
06569        || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
06570            && TCL_RELEASE_SERIAL >= 2) )
06571 EXTERN void TkConsoleCreate_ _((void));
06572 #endif
06573 #endif
06574 static VALUE
06575 ip_create_console_core(interp, argc, argv)
06576     VALUE interp;
06577     int   argc;   /* dummy */
06578     VALUE *argv;  /* dummy */
06579 {
06580     struct tcltkip *ptr = get_ip(interp);
06581 
06582     if (!tk_stubs_init_p()) {
06583         tcltkip_init_tk(interp);
06584     }
06585 
06586     if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) {
06587         Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
06588     }
06589 
06590 #if TCL_MAJOR_VERSION > 8 \
06591     || (TCL_MAJOR_VERSION == 8 \
06592         && (TCL_MINOR_VERSION > 1 \
06593             || (TCL_MINOR_VERSION == 1 \
06594                  && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
06595                  && TCL_RELEASE_SERIAL >= 1) ) )
06596     Tk_InitConsoleChannels(ptr->ip);
06597 
06598     if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) {
06599         rb_raise(rb_eRuntimeError, "fail to create console-window");
06600     }
06601 #else
06602 #if defined(MAC_TCL) || defined(__WIN32__)
06603 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06604     && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \
06605         || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) )
06606     TkConsoleCreate_();
06607 #else
06608     TkConsoleCreate();
06609 #endif
06610 
06611     if (TkConsoleInit(ptr->ip) != TCL_OK) {
06612         rb_raise(rb_eRuntimeError, "fail to create console-window");
06613     }
06614 #else
06615     rb_notimplement();
06616 #endif
06617 #endif
06618 
06619     return interp;
06620 }
06621 
06622 static VALUE
06623 ip_create_console(self)
06624     VALUE self;
06625 {
06626     struct tcltkip *ptr = get_ip(self);
06627 
06628     /* ip is deleted? */
06629     if (deleted_ip(ptr)) {
06630         rb_raise(rb_eRuntimeError, "interpreter is deleted");
06631     }
06632 
06633     return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self);
06634 }
06635 
06636 /* make ip "safe" */
06637 static VALUE
06638 ip_make_safe_core(interp, argc, argv)
06639     VALUE interp;
06640     int   argc;   /* dummy */
06641     VALUE *argv;  /* dummy */
06642 {
06643     struct tcltkip *ptr = get_ip(interp);
06644     Tk_Window mainWin;
06645 
06646     /* ip is deleted? */
06647     if (deleted_ip(ptr)) {
06648         return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
06649     }
06650 
06651     if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
06652         /* return rb_exc_new2(rb_eRuntimeError,
06653                               Tcl_GetStringResult(ptr->ip)); */
06654         return create_ip_exc(interp, rb_eRuntimeError,
06655                              Tcl_GetStringResult(ptr->ip));
06656     }
06657 
06658     ptr->allow_ruby_exit = 0;
06659 
06660     /* replace 'exit' command --> 'interp_exit' command */
06661     mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
06662 #if TCL_MAJOR_VERSION >= 8
06663     DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06664     Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
06665                          (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06666 #else /* TCL_MAJOR_VERSION < 8 */
06667     DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06668     Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
06669                       (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06670 #endif
06671 
06672     return interp;
06673 }
06674 
06675 static VALUE
06676 ip_make_safe(self)
06677     VALUE self;
06678 {
06679     struct tcltkip *ptr = get_ip(self);
06680 
06681     /* ip is deleted? */
06682     if (deleted_ip(ptr)) {
06683         rb_raise(rb_eRuntimeError, "interpreter is deleted");
06684     }
06685 
06686     return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self);
06687 }
06688 
06689 /* is safe? */
06690 static VALUE
06691 ip_is_safe_p(self)
06692     VALUE self;
06693 {
06694     struct tcltkip *ptr = get_ip(self);
06695 
06696     /* ip is deleted? */
06697     if (deleted_ip(ptr)) {
06698         rb_raise(rb_eRuntimeError, "interpreter is deleted");
06699     }
06700 
06701     if (Tcl_IsSafe(ptr->ip)) {
06702         return Qtrue;
06703     } else {
06704         return Qfalse;
06705     }
06706 }
06707 
06708 /* allow_ruby_exit? */
06709 static VALUE
06710 ip_allow_ruby_exit_p(self)
06711     VALUE self;
06712 {
06713     struct tcltkip *ptr = get_ip(self);
06714 
06715     /* ip is deleted? */
06716     if (deleted_ip(ptr)) {
06717         rb_raise(rb_eRuntimeError, "interpreter is deleted");
06718     }
06719 
06720     if (ptr->allow_ruby_exit) {
06721         return Qtrue;
06722     } else {
06723         return Qfalse;
06724     }
06725 }
06726 
06727 /* allow_ruby_exit = mode */
06728 static VALUE
06729 ip_allow_ruby_exit_set(self, val)
06730     VALUE self, val;
06731 {
06732     struct tcltkip *ptr = get_ip(self);
06733     Tk_Window mainWin;
06734 
06735     rb_secure(4);
06736 
06737     /* ip is deleted? */
06738     if (deleted_ip(ptr)) {
06739         rb_raise(rb_eRuntimeError, "interpreter is deleted");
06740     }
06741 
06742     if (Tcl_IsSafe(ptr->ip)) {
06743         rb_raise(rb_eSecurityError,
06744                  "insecure operation on a safe interpreter");
06745     }
06746 
06747     /*
06748      *  Because of cross-threading, the following line may fail to find
06749      *  the MainWindow, even if the Tcl/Tk interpreter has one or more.
06750      *  But it has no problem. Current implementation of both type of
06751      *  the "exit" command don't need maiinWin token.
06752      */
06753     mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
06754 
06755     if (RTEST(val)) {
06756         ptr->allow_ruby_exit = 1;
06757 #if TCL_MAJOR_VERSION >= 8
06758         DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
06759         Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
06760                              (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06761 #else /* TCL_MAJOR_VERSION < 8 */
06762         DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
06763         Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
06764                           (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06765 #endif
06766         return Qtrue;
06767 
06768     } else {
06769         ptr->allow_ruby_exit = 0;
06770 #if TCL_MAJOR_VERSION >= 8
06771         DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06772         Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
06773                              (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06774 #else /* TCL_MAJOR_VERSION < 8 */
06775         DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06776         Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
06777                           (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06778 #endif
06779         return Qfalse;
06780     }
06781 }
06782 
06783 /* delete interpreter */
06784 static VALUE
06785 ip_delete(self)
06786     VALUE self;
06787 {
06788     int  thr_crit_bup;
06789     struct tcltkip *ptr = get_ip(self);
06790 
06791     /* if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { */
06792     if (deleted_ip(ptr)) {
06793         DUMP1("delete deleted IP");
06794         return Qnil;
06795     }
06796 
06797     thr_crit_bup = rb_thread_critical;
06798     rb_thread_critical = Qtrue;
06799 
06800     DUMP1("delete interp");
06801     if (!Tcl_InterpDeleted(ptr->ip)) {
06802       DUMP1("call ip_finalize");
06803       ip_finalize(ptr->ip);
06804 
06805       Tcl_DeleteInterp(ptr->ip);
06806       Tcl_Release(ptr->ip);
06807     }
06808 
06809     rb_thread_critical = thr_crit_bup;
06810 
06811     return Qnil;
06812 }
06813 
06814 
06815 /* is deleted? */
06816 static VALUE
06817 ip_has_invalid_namespace_p(self)
06818     VALUE self;
06819 {
06820     struct tcltkip *ptr = get_ip(self);
06821 
06822     if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) {
06823         /* deleted IP */
06824         return Qtrue;
06825     }
06826 
06827 #if TCL_NAMESPACE_DEBUG
06828     if (rbtk_invalid_namespace(ptr)) {
06829         return Qtrue;
06830     } else {
06831         return Qfalse;
06832     }
06833 #else
06834     return Qfalse;
06835 #endif
06836 }
06837 
06838 static VALUE
06839 ip_is_deleted_p(self)
06840     VALUE self;
06841 {
06842     struct tcltkip *ptr = get_ip(self);
06843 
06844     if (deleted_ip(ptr)) {
06845         return Qtrue;
06846     } else {
06847         return Qfalse;
06848     }
06849 }
06850 
06851 static VALUE
06852 ip_has_mainwindow_p_core(self, argc, argv)
06853     VALUE self;
06854     int   argc;   /* dummy */
06855     VALUE *argv;  /* dummy */
06856 {
06857     struct tcltkip *ptr = get_ip(self);
06858 
06859     if (deleted_ip(ptr) || !tk_stubs_init_p()) {
06860         return Qnil;
06861     } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) {
06862         return Qfalse;
06863     } else {
06864         return Qtrue;
06865     }
06866 }
06867 
06868 static VALUE
06869 ip_has_mainwindow_p(self)
06870     VALUE self;
06871 {
06872     return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self);
06873 }
06874 
06875 
06876 /*** ruby string <=> tcl object ***/
06877 #if TCL_MAJOR_VERSION >= 8
06878 static VALUE
06879 get_str_from_obj(obj)
06880     Tcl_Obj *obj;
06881 {
06882     int len, binary = 0;
06883     const char *s;
06884     volatile VALUE str;
06885 
06886 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
06887     s = Tcl_GetStringFromObj(obj, &len);
06888 #else
06889 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3
06890      /* TCL_VERSION 8.1 -- 8.3 */
06891     if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) {
06892         /* possibly binary string */
06893         s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
06894         binary = 1;
06895     } else {
06896         /* possibly text string */
06897         s = Tcl_GetStringFromObj(obj, &len);
06898     }
06899 #else /* TCL_VERSION >= 8.4 */
06900     if (IS_TCL_BYTEARRAY(obj)) {
06901       s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
06902       binary = 1;
06903     } else {
06904       s = Tcl_GetStringFromObj(obj, &len);
06905     }
06906 
06907 #endif
06908 #endif
06909     str = s ? rb_str_new(s, len) : rb_str_new2("");
06910     if (binary) {
06911 #ifdef HAVE_RUBY_ENCODING_H
06912       rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
06913 #endif
06914       rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
06915 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
06916     } else {
06917 #ifdef HAVE_RUBY_ENCODING_H
06918       rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
06919 #endif
06920       rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
06921 #endif
06922     }
06923     return str;
06924 }
06925 
06926 static Tcl_Obj *
06927 get_obj_from_str(str)
06928     VALUE str;
06929 {
06930     const char *s = StringValuePtr(str);
06931 
06932 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
06933     return Tcl_NewStringObj((char*)s, RSTRING_LEN(str));
06934 #else /* TCL_VERSION >= 8.1 */
06935     VALUE enc = rb_attr_get(str, ID_at_enc);
06936 
06937     if (!NIL_P(enc)) {
06938         StringValue(enc);
06939         if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
06940             /* binary string */
06941             return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06942         } else {
06943             /* text string */
06944             return Tcl_NewStringObj(s, RSTRING_LENINT(str));
06945         }
06946 #ifdef HAVE_RUBY_ENCODING_H
06947     } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
06948         /* binary string */
06949         return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06950 #endif
06951     } else if (memchr(s, 0, RSTRING_LEN(str))) {
06952         /* probably binary string */
06953         return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06954     } else {
06955         /* probably text string */
06956         return Tcl_NewStringObj(s, RSTRING_LENINT(str));
06957     }
06958 #endif
06959 }
06960 #endif /* ruby string <=> tcl object */
06961 
06962 static VALUE
06963 ip_get_result_string_obj(interp)
06964     Tcl_Interp *interp;
06965 {
06966 #if TCL_MAJOR_VERSION >= 8
06967     Tcl_Obj *retObj;
06968     volatile VALUE strval;
06969 
06970     retObj = Tcl_GetObjResult(interp);
06971     Tcl_IncrRefCount(retObj);
06972     strval = get_str_from_obj(retObj);
06973     RbTk_OBJ_UNTRUST(strval);
06974     Tcl_ResetResult(interp);
06975     Tcl_DecrRefCount(retObj);
06976     return strval;
06977 #else
06978     return rb_tainted_str_new2(interp->result);
06979 #endif
06980 }
06981 
06982 /* call Tcl/Tk functions on the eventloop thread */
06983 static VALUE
06984 callq_safelevel_handler(arg, callq)
06985     VALUE arg;
06986     VALUE callq;
06987 {
06988     struct call_queue *q;
06989 
06990     Data_Get_Struct(callq, struct call_queue, q);
06991     DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
06992     rb_set_safe_level(q->safe_level);
06993     return((q->func)(q->interp, q->argc, q->argv));
06994 }
06995 
06996 static int call_queue_handler _((Tcl_Event *, int));
06997 static int
06998 call_queue_handler(evPtr, flags)
06999     Tcl_Event *evPtr;
07000     int flags;
07001 {
07002     struct call_queue *q = (struct call_queue *)evPtr;
07003     volatile VALUE ret;
07004     volatile VALUE q_dat;
07005     volatile VALUE thread = q->thread;
07006     struct tcltkip *ptr;
07007 
07008     DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
07009     DUMP2("call_queue_handler thread : %lx", rb_thread_current());
07010     DUMP2("added by thread : %lx", thread);
07011 
07012     if (*(q->done)) {
07013         DUMP1("processed by another event-loop");
07014         return 0;
07015     } else {
07016         DUMP1("process it on current event-loop");
07017     }
07018 
07019 #ifdef RUBY_VM
07020     if (RTEST(rb_funcall(thread, ID_alive_p, 0))
07021         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07022 #else
07023     if (RTEST(rb_thread_alive_p(thread))
07024         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07025 #endif
07026       DUMP1("caller is not yet ready to receive the result -> pending");
07027       return 0;
07028     }
07029 
07030     /* process it */
07031     *(q->done) = 1;
07032 
07033     /* deleted ipterp ? */
07034     ptr = get_ip(q->interp);
07035     if (deleted_ip(ptr)) {
07036         /* deleted IP --> ignore */
07037         return 1;
07038     }
07039 
07040     /* incr internal handler mark */
07041     rbtk_internal_eventloop_handler++;
07042 
07043     /* check safe-level */
07044     if (rb_safe_level() != q->safe_level) {
07045         /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
07046         q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,-1,q);
07047         ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
07048                          ID_call, 0);
07049         rb_gc_force_recycle(q_dat);
07050         q_dat = (VALUE)NULL;
07051     } else {
07052         DUMP2("call function (for caller thread:%lx)", thread);
07053         DUMP2("call function (current thread:%lx)", rb_thread_current());
07054         ret = (q->func)(q->interp, q->argc, q->argv);
07055     }
07056 
07057     /* set result */
07058     RARRAY_PTR(q->result)[0] = ret;
07059     ret = (VALUE)NULL;
07060 
07061     /* decr internal handler mark */
07062     rbtk_internal_eventloop_handler--;
07063 
07064     /* complete */
07065     *(q->done) = -1;
07066 
07067     /* unlink ruby objects */
07068     q->argv = (VALUE*)NULL;
07069     q->interp = (VALUE)NULL;
07070     q->result = (VALUE)NULL;
07071     q->thread = (VALUE)NULL;
07072 
07073     /* back to caller */
07074 #ifdef RUBY_VM
07075     if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
07076 #else
07077     if (RTEST(rb_thread_alive_p(thread))) {
07078 #endif
07079       DUMP2("back to caller (caller thread:%lx)", thread);
07080       DUMP2("               (current thread:%lx)", rb_thread_current());
07081 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
07082       have_rb_thread_waiting_for_value = 1;
07083       rb_thread_wakeup(thread);
07084 #else
07085       rb_thread_run(thread);
07086 #endif
07087       DUMP1("finish back to caller");
07088 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
07089       rb_thread_schedule();
07090 #endif
07091     } else {
07092       DUMP2("caller is dead (caller thread:%lx)", thread);
07093       DUMP2("               (current thread:%lx)", rb_thread_current());
07094     }
07095 
07096     /* end of handler : remove it */
07097     return 1;
07098 }
07099 
07100 static VALUE
07101 tk_funcall(func, argc, argv, obj)
07102     VALUE (*func)();
07103     int argc;
07104     VALUE *argv;
07105     VALUE obj;
07106 {
07107     struct call_queue *callq;
07108     struct tcltkip *ptr;
07109     int  *alloc_done;
07110     int  thr_crit_bup;
07111     int  is_tk_evloop_thread;
07112     volatile VALUE current = rb_thread_current();
07113     volatile VALUE ip_obj = obj;
07114     volatile VALUE result;
07115     volatile VALUE ret;
07116     struct timeval t;
07117 
07118     if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) {
07119         ptr = get_ip(ip_obj);
07120         if (deleted_ip(ptr)) return Qnil;
07121     } else {
07122         ptr = (struct tcltkip *)NULL;
07123     }
07124 
07125 #ifdef RUBY_USE_NATIVE_THREAD
07126     if (ptr) {
07127       /* on Tcl interpreter */
07128       is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0
07129                              || ptr->tk_thread_id == Tcl_GetCurrentThread());
07130     } else {
07131       /* on Tcl/Tk library */
07132       is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0
07133                              || tk_eventloop_thread_id == Tcl_GetCurrentThread());
07134     }
07135 #else
07136     is_tk_evloop_thread = 1;
07137 #endif
07138 
07139     if (is_tk_evloop_thread
07140         && (NIL_P(eventloop_thread) || current == eventloop_thread)
07141         ) {
07142         if (NIL_P(eventloop_thread)) {
07143             DUMP2("tk_funcall from thread:%lx but no eventloop", current);
07144         } else {
07145             DUMP2("tk_funcall from current eventloop %lx", current);
07146         }
07147         result = (func)(ip_obj, argc, argv);
07148         if (rb_obj_is_kind_of(result, rb_eException)) {
07149             rb_exc_raise(result);
07150         }
07151         return result;
07152     }
07153 
07154     DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current);
07155 
07156     thr_crit_bup = rb_thread_critical;
07157     rb_thread_critical = Qtrue;
07158 
07159     /* allocate memory (argv cross over thread : must be in heap) */
07160     if (argv) {
07161         /* VALUE *temp = ALLOC_N(VALUE, argc); */
07162         VALUE *temp = RbTk_ALLOC_N(VALUE, argc);
07163 #if 0 /* use Tcl_Preserve/Release */
07164         Tcl_Preserve((ClientData)temp); /* XXXXXXXX */
07165 #endif
07166         MEMCPY(temp, argv, VALUE, argc);
07167         argv = temp;
07168     }
07169 
07170     /* allocate memory (keep result) */
07171     /* alloc_done = (int*)ALLOC(int); */
07172     alloc_done = RbTk_ALLOC_N(int, 1);
07173 #if 0 /* use Tcl_Preserve/Release */
07174     Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
07175 #endif
07176     *alloc_done = 0;
07177 
07178     /* allocate memory (freed by Tcl_ServiceEvent) */
07179     /* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */
07180     callq = RbTk_ALLOC_N(struct call_queue, 1);
07181 #if 0 /* use Tcl_Preserve/Release */
07182     Tcl_Preserve(callq);
07183 #endif
07184 
07185     /* allocate result obj */
07186     result = rb_ary_new3(1, Qnil);
07187 
07188     /* construct event data */
07189     callq->done = alloc_done;
07190     callq->func = func;
07191     callq->argc = argc;
07192     callq->argv = argv;
07193     callq->interp = ip_obj;
07194     callq->result = result;
07195     callq->thread = current;
07196     callq->safe_level = rb_safe_level();
07197     callq->ev.proc = call_queue_handler;
07198 
07199     /* add the handler to Tcl event queue */
07200     DUMP1("add handler");
07201 #ifdef RUBY_USE_NATIVE_THREAD
07202     if (ptr && ptr->tk_thread_id) {
07203       /* Tcl_ThreadQueueEvent(ptr->tk_thread_id,
07204                            &(callq->ev), TCL_QUEUE_HEAD); */
07205       Tcl_ThreadQueueEvent(ptr->tk_thread_id,
07206                            (Tcl_Event*)callq, TCL_QUEUE_HEAD);
07207       Tcl_ThreadAlert(ptr->tk_thread_id);
07208     } else if (tk_eventloop_thread_id) {
07209       /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
07210                            &(callq->ev), TCL_QUEUE_HEAD); */
07211       Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
07212                            (Tcl_Event*)callq, TCL_QUEUE_HEAD);
07213       Tcl_ThreadAlert(tk_eventloop_thread_id);
07214     } else {
07215       /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
07216       Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
07217     }
07218 #else
07219     /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
07220     Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
07221 #endif
07222 
07223     rb_thread_critical = thr_crit_bup;
07224 
07225     /* wait for the handler to be processed */
07226     t.tv_sec  = 0;
07227     t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
07228 
07229     DUMP2("callq wait for handler (current thread:%lx)", current);
07230     while(*alloc_done >= 0) {
07231       DUMP2("*** callq wait for handler (current thread:%lx)", current);
07232       /* rb_thread_stop(); */
07233       /* rb_thread_sleep_forever(); */
07234       rb_thread_wait_for(t);
07235       DUMP2("*** callq wakeup (current thread:%lx)", current);
07236       DUMP2("***            (eventloop thread:%lx)", eventloop_thread);
07237       if (NIL_P(eventloop_thread)) {
07238         DUMP1("*** callq lost eventloop thread");
07239         break;
07240       }
07241     }
07242     DUMP2("back from handler (current thread:%lx)", current);
07243 
07244     /* get result & free allocated memory */
07245     ret = RARRAY_PTR(result)[0];
07246 #if 0 /* use Tcl_EventuallyFree */
07247     Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
07248 #else
07249 #if 0 /* use Tcl_Preserve/Release */
07250     Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
07251 #else
07252     /* free(alloc_done); */
07253     ckfree((char*)alloc_done);
07254 #endif
07255 #endif
07256     /* if (argv) free(argv); */
07257     if (argv) {
07258       /* if argv != NULL, alloc as 'temp' */
07259       int i;
07260       for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; }
07261 
07262 #if 0 /* use Tcl_EventuallyFree */
07263       Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
07264 #else
07265 #if 0 /* use Tcl_Preserve/Release */
07266       Tcl_Release((ClientData)argv); /* XXXXXXXX */
07267 #else
07268       ckfree((char*)argv);
07269 #endif
07270 #endif
07271     }
07272 
07273 #if 0 /* callq is freed by Tcl_ServiceEvent */
07274 #if 0 /* use Tcl_Preserve/Release */
07275     Tcl_Release(callq);
07276 #else
07277     ckfree((char*)callq);
07278 #endif
07279 #endif
07280 
07281     /* exception? */
07282     if (rb_obj_is_kind_of(ret, rb_eException)) {
07283         DUMP1("raise exception");
07284         /* rb_exc_raise(ret); */
07285         rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
07286                                  rb_funcall(ret, ID_to_s, 0, 0)));
07287     }
07288 
07289     DUMP1("exit tk_funcall");
07290     return ret;
07291 }
07292 
07293 
07294 /* eval string in tcl by Tcl_Eval() */
07295 #if TCL_MAJOR_VERSION >= 8
07296 struct call_eval_info {
07297     struct tcltkip *ptr;
07298     Tcl_Obj *cmd;
07299 };
07300 
07301 static VALUE
07302 #ifdef HAVE_PROTOTYPES
07303 call_tcl_eval(VALUE arg)
07304 #else
07305 call_tcl_eval(arg)
07306     VALUE arg;
07307 #endif
07308 {
07309     struct call_eval_info *inf = (struct call_eval_info *)arg;
07310 
07311     Tcl_AllowExceptions(inf->ptr->ip);
07312     inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd);
07313 
07314     return Qnil;
07315 }
07316 #endif
07317 
07318 static VALUE
07319 ip_eval_real(self, cmd_str, cmd_len)
07320     VALUE self;
07321     char *cmd_str;
07322     int  cmd_len;
07323 {
07324     volatile VALUE ret;
07325     struct tcltkip *ptr = get_ip(self);
07326     int thr_crit_bup;
07327 
07328 #if TCL_MAJOR_VERSION >= 8
07329     /* call Tcl_EvalObj() */
07330     {
07331       Tcl_Obj *cmd;
07332 
07333       thr_crit_bup = rb_thread_critical;
07334       rb_thread_critical = Qtrue;
07335 
07336       cmd = Tcl_NewStringObj(cmd_str, cmd_len);
07337       Tcl_IncrRefCount(cmd);
07338 
07339       /* ip is deleted? */
07340       if (deleted_ip(ptr)) {
07341           Tcl_DecrRefCount(cmd);
07342           rb_thread_critical = thr_crit_bup;
07343           ptr->return_value = TCL_OK;
07344           return rb_tainted_str_new2("");
07345       } else {
07346           int status;
07347           struct call_eval_info inf;
07348 
07349           /* Tcl_Preserve(ptr->ip); */
07350           rbtk_preserve_ip(ptr);
07351 
07352 #if 0
07353           ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
07354           /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */
07355 #else
07356           inf.ptr = ptr;
07357           inf.cmd = cmd;
07358           ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status);
07359           switch(status) {
07360           case TAG_RAISE:
07361               if (NIL_P(rb_errinfo())) {
07362                   rbtk_pending_exception = rb_exc_new2(rb_eException,
07363                                                        "unknown exception");
07364               } else {
07365                   rbtk_pending_exception = rb_errinfo();
07366               }
07367               break;
07368 
07369           case TAG_FATAL:
07370               if (NIL_P(rb_errinfo())) {
07371                   rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
07372               } else {
07373                   rbtk_pending_exception = rb_errinfo();
07374               }
07375           }
07376 #endif
07377       }
07378 
07379       Tcl_DecrRefCount(cmd);
07380 
07381     }
07382 
07383     if (pending_exception_check1(thr_crit_bup, ptr)) {
07384         rbtk_release_ip(ptr);
07385         return rbtk_pending_exception;
07386     }
07387 
07388     /* if (ptr->return_value == TCL_ERROR) { */
07389     if (ptr->return_value != TCL_OK) {
07390         if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
07391             volatile VALUE exc;
07392 
07393             switch (ptr->return_value) {
07394             case TCL_RETURN:
07395               exc = create_ip_exc(self, eTkCallbackReturn,
07396                                   "ip_eval_real receives TCL_RETURN");
07397             case TCL_BREAK:
07398               exc = create_ip_exc(self, eTkCallbackBreak,
07399                                   "ip_eval_real receives TCL_BREAK");
07400             case TCL_CONTINUE:
07401               exc = create_ip_exc(self, eTkCallbackContinue,
07402                                   "ip_eval_real receives TCL_CONTINUE");
07403             default:
07404               exc = create_ip_exc(self, rb_eRuntimeError, "%s",
07405                                   Tcl_GetStringResult(ptr->ip));
07406             }
07407 
07408             rbtk_release_ip(ptr);
07409             rb_thread_critical = thr_crit_bup;
07410             return exc;
07411         } else {
07412             if (event_loop_abort_on_exc < 0) {
07413                 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
07414             } else {
07415                 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
07416             }
07417             Tcl_ResetResult(ptr->ip);
07418             rbtk_release_ip(ptr);
07419             rb_thread_critical = thr_crit_bup;
07420             return rb_tainted_str_new2("");
07421         }
07422     }
07423 
07424     /* pass back the result (as string) */
07425     ret =  ip_get_result_string_obj(ptr->ip);
07426     rbtk_release_ip(ptr);
07427     rb_thread_critical = thr_crit_bup;
07428     return ret;
07429 
07430 #else /* TCL_MAJOR_VERSION < 8 */
07431     DUMP2("Tcl_Eval(%s)", cmd_str);
07432 
07433     /* ip is deleted? */
07434     if (deleted_ip(ptr)) {
07435         ptr->return_value = TCL_OK;
07436         return rb_tainted_str_new2("");
07437     } else {
07438         /* Tcl_Preserve(ptr->ip); */
07439         rbtk_preserve_ip(ptr);
07440         ptr->return_value = Tcl_Eval(ptr->ip, cmd_str);
07441         /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */
07442     }
07443 
07444     if (pending_exception_check1(thr_crit_bup, ptr)) {
07445         rbtk_release_ip(ptr);
07446         return rbtk_pending_exception;
07447     }
07448 
07449     /* if (ptr->return_value == TCL_ERROR) { */
07450     if (ptr->return_value != TCL_OK) {
07451         volatile VALUE exc;
07452 
07453         switch (ptr->return_value) {
07454         case TCL_RETURN:
07455           exc = create_ip_exc(self, eTkCallbackReturn,
07456                               "ip_eval_real receives TCL_RETURN");
07457         case TCL_BREAK:
07458           exc = create_ip_exc(self, eTkCallbackBreak,
07459                               "ip_eval_real receives TCL_BREAK");
07460         case TCL_CONTINUE:
07461           exc = create_ip_exc(self, eTkCallbackContinue,
07462                                "ip_eval_real receives TCL_CONTINUE");
07463         default:
07464           exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
07465         }
07466 
07467         rbtk_release_ip(ptr);
07468         return exc;
07469     }
07470     DUMP2("(TCL_Eval result) %d", ptr->return_value);
07471 
07472     /* pass back the result (as string) */
07473     ret =  ip_get_result_string_obj(ptr->ip);
07474     rbtk_release_ip(ptr);
07475     return ret;
07476 #endif
07477 }
07478 
07479 static VALUE
07480 evq_safelevel_handler(arg, evq)
07481     VALUE arg;
07482     VALUE evq;
07483 {
07484     struct eval_queue *q;
07485 
07486     Data_Get_Struct(evq, struct eval_queue, q);
07487     DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
07488     rb_set_safe_level(q->safe_level);
07489     return ip_eval_real(q->interp, q->str, q->len);
07490 }
07491 
07492 int eval_queue_handler _((Tcl_Event *, int));
07493 int
07494 eval_queue_handler(evPtr, flags)
07495     Tcl_Event *evPtr;
07496     int flags;
07497 {
07498     struct eval_queue *q = (struct eval_queue *)evPtr;
07499     volatile VALUE ret;
07500     volatile VALUE q_dat;
07501     volatile VALUE thread = q->thread;
07502     struct tcltkip *ptr;
07503 
07504     DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
07505     DUMP2("eval_queue_thread : %lx", rb_thread_current());
07506     DUMP2("added by thread : %lx", thread);
07507 
07508     if (*(q->done)) {
07509         DUMP1("processed by another event-loop");
07510         return 0;
07511     } else {
07512         DUMP1("process it on current event-loop");
07513     }
07514 
07515 #ifdef RUBY_VM
07516     if (RTEST(rb_funcall(thread, ID_alive_p, 0))
07517         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07518 #else
07519     if (RTEST(rb_thread_alive_p(thread))
07520         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07521 #endif
07522       DUMP1("caller is not yet ready to receive the result -> pending");
07523       return 0;
07524     }
07525 
07526     /* process it */
07527     *(q->done) = 1;
07528 
07529     /* deleted ipterp ? */
07530     ptr = get_ip(q->interp);
07531     if (deleted_ip(ptr)) {
07532         /* deleted IP --> ignore */
07533         return 1;
07534     }
07535 
07536     /* incr internal handler mark */
07537     rbtk_internal_eventloop_handler++;
07538 
07539     /* check safe-level */
07540     if (rb_safe_level() != q->safe_level) {
07541 #ifdef HAVE_NATIVETHREAD
07542 #ifndef RUBY_USE_NATIVE_THREAD
07543     if (!ruby_native_thread_p()) {
07544       rb_bug("cross-thread violation on eval_queue_handler()");
07545     }
07546 #endif
07547 #endif
07548         /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
07549         q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,-1,q);
07550         ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
07551                          ID_call, 0);
07552         rb_gc_force_recycle(q_dat);
07553         q_dat = (VALUE)NULL;
07554     } else {
07555         ret = ip_eval_real(q->interp, q->str, q->len);
07556     }
07557 
07558     /* set result */
07559     RARRAY_PTR(q->result)[0] = ret;
07560     ret = (VALUE)NULL;
07561 
07562     /* decr internal handler mark */
07563     rbtk_internal_eventloop_handler--;
07564 
07565     /* complete */
07566     *(q->done) = -1;
07567 
07568     /* unlink ruby objects */
07569     q->interp = (VALUE)NULL;
07570     q->result = (VALUE)NULL;
07571     q->thread = (VALUE)NULL;
07572 
07573     /* back to caller */
07574 #ifdef RUBY_VM
07575     if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
07576 #else
07577     if (RTEST(rb_thread_alive_p(thread))) {
07578 #endif
07579       DUMP2("back to caller (caller thread:%lx)", thread);
07580       DUMP2("               (current thread:%lx)", rb_thread_current());
07581 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
07582       have_rb_thread_waiting_for_value = 1;
07583       rb_thread_wakeup(thread);
07584 #else
07585       rb_thread_run(thread);
07586 #endif
07587       DUMP1("finish back to caller");
07588 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
07589       rb_thread_schedule();
07590 #endif
07591     } else {
07592       DUMP2("caller is dead (caller thread:%lx)", thread);
07593       DUMP2("               (current thread:%lx)", rb_thread_current());
07594     }
07595 
07596     /* end of handler : remove it */
07597     return 1;
07598 }
07599 
07600 static VALUE
07601 ip_eval(self, str)
07602     VALUE self;
07603     VALUE str;
07604 {
07605     struct eval_queue *evq;
07606 #ifdef RUBY_USE_NATIVE_THREAD
07607     struct tcltkip *ptr;
07608 #endif
07609     char *eval_str;
07610     int  *alloc_done;
07611     int  thr_crit_bup;
07612     volatile VALUE current = rb_thread_current();
07613     volatile VALUE ip_obj = self;
07614     volatile VALUE result;
07615     volatile VALUE ret;
07616     Tcl_QueuePosition position;
07617     struct timeval t;
07618 
07619     thr_crit_bup = rb_thread_critical;
07620     rb_thread_critical = Qtrue;
07621     StringValue(str);
07622     rb_thread_critical = thr_crit_bup;
07623 
07624 #ifdef RUBY_USE_NATIVE_THREAD
07625     ptr = get_ip(ip_obj);
07626     DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id);
07627     DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
07628 #else
07629     DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
07630 #endif
07631     DUMP2("status: eventloopt_thread %lx", eventloop_thread);
07632 
07633     if (
07634 #ifdef RUBY_USE_NATIVE_THREAD
07635         (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
07636         &&
07637 #endif
07638         (NIL_P(eventloop_thread) || current == eventloop_thread)
07639         ) {
07640         if (NIL_P(eventloop_thread)) {
07641             DUMP2("eval from thread:%lx but no eventloop", current);
07642         } else {
07643             DUMP2("eval from current eventloop %lx", current);
07644         }
07645         result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str));
07646         if (rb_obj_is_kind_of(result, rb_eException)) {
07647             rb_exc_raise(result);
07648         }
07649         return result;
07650     }
07651 
07652     DUMP2("eval from thread %lx (NOT current eventloop)", current);
07653 
07654     thr_crit_bup = rb_thread_critical;
07655     rb_thread_critical = Qtrue;
07656 
07657     /* allocate memory (keep result) */
07658     /* alloc_done = (int*)ALLOC(int); */
07659     alloc_done = RbTk_ALLOC_N(int, 1);
07660 #if 0 /* use Tcl_Preserve/Release */
07661     Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
07662 #endif
07663     *alloc_done = 0;
07664 
07665     /* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */
07666     eval_str = ckalloc(RSTRING_LENINT(str) + 1);
07667 #if 0 /* use Tcl_Preserve/Release */
07668     Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */
07669 #endif
07670     memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str));
07671     eval_str[RSTRING_LEN(str)] = 0;
07672 
07673     /* allocate memory (freed by Tcl_ServiceEvent) */
07674     /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */
07675     evq = RbTk_ALLOC_N(struct eval_queue, 1);
07676 #if 0 /* use Tcl_Preserve/Release */
07677     Tcl_Preserve(evq);
07678 #endif
07679 
07680     /* allocate result obj */
07681     result = rb_ary_new3(1, Qnil);
07682 
07683     /* construct event data */
07684     evq->done = alloc_done;
07685     evq->str = eval_str;
07686     evq->len = RSTRING_LENINT(str);
07687     evq->interp = ip_obj;
07688     evq->result = result;
07689     evq->thread = current;
07690     evq->safe_level = rb_safe_level();
07691     evq->ev.proc = eval_queue_handler;
07692 
07693     position = TCL_QUEUE_TAIL;
07694 
07695     /* add the handler to Tcl event queue */
07696     DUMP1("add handler");
07697 #ifdef RUBY_USE_NATIVE_THREAD
07698     if (ptr->tk_thread_id) {
07699       /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */
07700       Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position);
07701       Tcl_ThreadAlert(ptr->tk_thread_id);
07702     } else if (tk_eventloop_thread_id) {
07703       Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position);
07704       /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
07705                            &(evq->ev), position); */
07706       Tcl_ThreadAlert(tk_eventloop_thread_id);
07707     } else {
07708       /* Tcl_QueueEvent(&(evq->ev), position); */
07709       Tcl_QueueEvent((Tcl_Event*)evq, position);
07710     }
07711 #else
07712     /* Tcl_QueueEvent(&(evq->ev), position); */
07713     Tcl_QueueEvent((Tcl_Event*)evq, position);
07714 #endif
07715 
07716     rb_thread_critical = thr_crit_bup;
07717 
07718     /* wait for the handler to be processed */
07719     t.tv_sec  = 0;
07720     t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
07721 
07722     DUMP2("evq wait for handler (current thread:%lx)", current);
07723     while(*alloc_done >= 0) {
07724       DUMP2("*** evq wait for handler (current thread:%lx)", current);
07725       /* rb_thread_stop(); */
07726       /* rb_thread_sleep_forever(); */
07727       rb_thread_wait_for(t);
07728       DUMP2("*** evq wakeup (current thread:%lx)", current);
07729       DUMP2("***          (eventloop thread:%lx)", eventloop_thread);
07730       if (NIL_P(eventloop_thread)) {
07731         DUMP1("*** evq lost eventloop thread");
07732         break;
07733       }
07734     }
07735     DUMP2("back from handler (current thread:%lx)", current);
07736 
07737     /* get result & free allocated memory */
07738     ret = RARRAY_PTR(result)[0];
07739 
07740 #if 0 /* use Tcl_EventuallyFree */
07741     Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
07742 #else
07743 #if 0 /* use Tcl_Preserve/Release */
07744     Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
07745 #else
07746     /* free(alloc_done); */
07747     ckfree((char*)alloc_done);
07748 #endif
07749 #endif
07750 #if 0 /* use Tcl_EventuallyFree */
07751     Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */
07752 #else
07753 #if 0 /* use Tcl_Preserve/Release */
07754     Tcl_Release((ClientData)eval_str); /* XXXXXXXX */
07755 #else
07756     /* free(eval_str); */
07757     ckfree(eval_str);
07758 #endif
07759 #endif
07760 #if 0 /* evq is freed by Tcl_ServiceEvent */
07761 #if 0 /* use Tcl_Preserve/Release */
07762     Tcl_Release(evq);
07763 #else
07764     ckfree((char*)evq);
07765 #endif
07766 #endif
07767 
07768     if (rb_obj_is_kind_of(ret, rb_eException)) {
07769         DUMP1("raise exception");
07770         /* rb_exc_raise(ret); */
07771         rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
07772                                  rb_funcall(ret, ID_to_s, 0, 0)));
07773     }
07774 
07775     return ret;
07776 }
07777 
07778 
07779 static int
07780 ip_cancel_eval_core(interp, msg, flag)
07781     Tcl_Interp *interp;
07782     VALUE msg;
07783     int flag;
07784 {
07785 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6)
07786     rb_raise(rb_eNotImpError,
07787              "cancel_eval is supported Tcl/Tk8.6 or later.");
07788 
07789     UNREACHABLE;
07790 #else
07791     Tcl_Obj *msg_obj;
07792 
07793     if (NIL_P(msg)) {
07794       msg_obj = NULL;
07795     } else {
07796       msg_obj = Tcl_NewStringObj(RSTRING_PTR(msg), RSTRING_LEN(msg));
07797       Tcl_IncrRefCount(msg_obj);
07798     }
07799 
07800     return Tcl_CancelEval(interp, msg_obj, 0, flag);
07801 #endif
07802 }
07803 
07804 static VALUE
07805 ip_cancel_eval(argc, argv, self)
07806     int   argc;
07807     VALUE *argv;
07808     VALUE self;
07809 {
07810     VALUE retval;
07811 
07812     if (rb_scan_args(argc, argv, "01", &retval) == 0) {
07813         retval = Qnil;
07814     }
07815     if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) {
07816       return Qtrue;
07817     } else {
07818       return Qfalse;
07819     }
07820 }
07821 
07822 #ifndef TCL_CANCEL_UNWIND
07823 #define TCL_CANCEL_UNWIND 0x100000
07824 #endif
07825 static VALUE
07826 ip_cancel_eval_unwind(argc, argv, self)
07827     int   argc;
07828     VALUE *argv;
07829     VALUE self;
07830 {
07831     int flag = 0;
07832     VALUE retval;
07833 
07834     if (rb_scan_args(argc, argv, "01", &retval) == 0) {
07835         retval = Qnil;
07836     }
07837 
07838     flag |= TCL_CANCEL_UNWIND;
07839     if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) {
07840       return Qtrue;
07841     } else {
07842       return Qfalse;
07843     }
07844 }
07845 
07846 /* restart Tk */
07847 static VALUE
07848 lib_restart_core(interp, argc, argv)
07849     VALUE interp;
07850     int   argc;   /* dummy */
07851     VALUE *argv;  /* dummy */
07852 {
07853     volatile VALUE exc;
07854     struct tcltkip *ptr = get_ip(interp);
07855     int  thr_crit_bup;
07856 
07857     /* rb_secure(4); */ /* already checked */
07858 
07859     /* tcl_stubs_check(); */ /* already checked */
07860 
07861     /* ip is deleted? */
07862     if (deleted_ip(ptr)) {
07863         return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
07864     }
07865 
07866     thr_crit_bup = rb_thread_critical;
07867     rb_thread_critical = Qtrue;
07868 
07869     /* Tcl_Preserve(ptr->ip); */
07870     rbtk_preserve_ip(ptr);
07871 
07872     /* destroy the root wdiget */
07873     ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
07874     /* ignore ERROR */
07875     DUMP2("(TCL_Eval result) %d", ptr->return_value);
07876     Tcl_ResetResult(ptr->ip);
07877 
07878 #if TCL_MAJOR_VERSION >= 8
07879     /* delete namespace ( tested on tk8.4.5 ) */
07880     ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
07881     /* ignore ERROR */
07882     DUMP2("(TCL_Eval result) %d", ptr->return_value);
07883     Tcl_ResetResult(ptr->ip);
07884 #endif
07885 
07886     /* delete trace proc ( tested on tk8.4.5 ) */
07887     ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
07888     /* ignore ERROR */
07889     DUMP2("(TCL_Eval result) %d", ptr->return_value);
07890     Tcl_ResetResult(ptr->ip);
07891 
07892     /* execute Tk_Init or Tk_SafeInit */
07893     exc = tcltkip_init_tk(interp);
07894     if (!NIL_P(exc)) {
07895         rb_thread_critical = thr_crit_bup;
07896         rbtk_release_ip(ptr);
07897         return exc;
07898     }
07899 
07900     /* Tcl_Release(ptr->ip); */
07901     rbtk_release_ip(ptr);
07902 
07903     rb_thread_critical = thr_crit_bup;
07904 
07905     /* return Qnil; */
07906     return interp;
07907 }
07908 
07909 static VALUE
07910 lib_restart(self)
07911     VALUE self;
07912 {
07913     struct tcltkip *ptr = get_ip(self);
07914 
07915     rb_secure(4);
07916 
07917     tcl_stubs_check();
07918 
07919     /* ip is deleted? */
07920     if (deleted_ip(ptr)) {
07921         rb_raise(rb_eRuntimeError, "interpreter is deleted");
07922     }
07923 
07924     return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self);
07925 }
07926 
07927 
07928 static VALUE
07929 ip_restart(self)
07930     VALUE self;
07931 {
07932     struct tcltkip *ptr = get_ip(self);
07933 
07934     rb_secure(4);
07935 
07936     tcl_stubs_check();
07937 
07938     /* ip is deleted? */
07939     if (deleted_ip(ptr)) {
07940         rb_raise(rb_eRuntimeError, "interpreter is deleted");
07941     }
07942 
07943     if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
07944         /* slave IP */
07945         return Qnil;
07946     }
07947     return lib_restart(self);
07948 }
07949 
07950 static VALUE
07951 lib_toUTF8_core(ip_obj, src, encodename)
07952     VALUE ip_obj;
07953     VALUE src;
07954     VALUE encodename;
07955 {
07956     volatile VALUE str = src;
07957 
07958 #ifdef TCL_UTF_MAX
07959     Tcl_Interp *interp;
07960     Tcl_Encoding encoding;
07961     Tcl_DString dstr;
07962     int taint_flag = OBJ_TAINTED(str);
07963     struct tcltkip *ptr;
07964     char *buf;
07965     int thr_crit_bup;
07966 #endif
07967 
07968     tcl_stubs_check();
07969 
07970     if (NIL_P(src)) {
07971       return rb_str_new2("");
07972     }
07973 
07974 #ifdef TCL_UTF_MAX
07975     if (NIL_P(ip_obj)) {
07976         interp = (Tcl_Interp *)NULL;
07977     } else {
07978         ptr = get_ip(ip_obj);
07979 
07980         /* ip is deleted? */
07981         if (deleted_ip(ptr)) {
07982             interp = (Tcl_Interp *)NULL;
07983         } else {
07984             interp = ptr->ip;
07985         }
07986     }
07987 
07988     thr_crit_bup = rb_thread_critical;
07989     rb_thread_critical = Qtrue;
07990 
07991     if (NIL_P(encodename)) {
07992         if (TYPE(str) == T_STRING) {
07993             volatile VALUE enc;
07994 
07995 #ifdef HAVE_RUBY_ENCODING_H
07996             enc = rb_funcall(rb_obj_encoding(str), ID_to_s, 0, 0);
07997 #else
07998             enc = rb_attr_get(str, ID_at_enc);
07999 #endif
08000             if (NIL_P(enc)) {
08001                 if (NIL_P(ip_obj)) {
08002                     encoding = (Tcl_Encoding)NULL;
08003                 } else {
08004                     enc = rb_attr_get(ip_obj, ID_at_enc);
08005                     if (NIL_P(enc)) {
08006                         encoding = (Tcl_Encoding)NULL;
08007                     } else {
08008                         /* StringValue(enc); */
08009                         enc = rb_funcall(enc, ID_to_s, 0, 0);
08010                         /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
08011                         if (!RSTRING_LEN(enc)) {
08012                           encoding = (Tcl_Encoding)NULL;
08013                         } else {
08014                           encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08015                                                      RSTRING_PTR(enc));
08016                           if (encoding == (Tcl_Encoding)NULL) {
08017                             rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08018                           }
08019                         }
08020                     }
08021                 }
08022             } else {
08023                 StringValue(enc);
08024                 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
08025 #ifdef HAVE_RUBY_ENCODING_H
08026                     rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08027 #endif
08028                     rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08029                     rb_thread_critical = thr_crit_bup;
08030                     return str;
08031                 }
08032                 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
08033                 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08034                                            RSTRING_PTR(enc));
08035                 if (encoding == (Tcl_Encoding)NULL) {
08036                     rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08037                 }
08038             }
08039         } else {
08040             encoding = (Tcl_Encoding)NULL;
08041         }
08042     } else {
08043         StringValue(encodename);
08044         if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
08045 #ifdef HAVE_RUBY_ENCODING_H
08046           rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08047 #endif
08048           rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08049           rb_thread_critical = thr_crit_bup;
08050           return str;
08051         }
08052         /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
08053         encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
08054         if (encoding == (Tcl_Encoding)NULL) {
08055             /*
08056             rb_warning("unknown encoding name '%s'",
08057                        RSTRING_PTR(encodename));
08058             */
08059             rb_raise(rb_eArgError, "unknown encoding name '%s'",
08060                      RSTRING_PTR(encodename));
08061         }
08062     }
08063 
08064     StringValue(str);
08065     if (!RSTRING_LEN(str)) {
08066         rb_thread_critical = thr_crit_bup;
08067         return str;
08068     }
08069     buf = ALLOC_N(char, RSTRING_LEN(str)+1);
08070     /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
08071     memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
08072     buf[RSTRING_LEN(str)] = 0;
08073 
08074     Tcl_DStringInit(&dstr);
08075     Tcl_DStringFree(&dstr);
08076     /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */
08077     Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr);
08078 
08079     /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
08080     /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
08081     str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
08082 #ifdef HAVE_RUBY_ENCODING_H
08083     rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
08084 #endif
08085     if (taint_flag) RbTk_OBJ_UNTRUST(str);
08086     rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
08087 
08088     /*
08089     if (encoding != (Tcl_Encoding)NULL) {
08090         Tcl_FreeEncoding(encoding);
08091     }
08092     */
08093     Tcl_DStringFree(&dstr);
08094 
08095     xfree(buf);
08096     /* ckfree(buf); */
08097 
08098     rb_thread_critical = thr_crit_bup;
08099 #endif
08100 
08101     return str;
08102 }
08103 
08104 static VALUE
08105 lib_toUTF8(argc, argv, self)
08106     int   argc;
08107     VALUE *argv;
08108     VALUE self;
08109 {
08110     VALUE str, encodename;
08111 
08112     if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08113         encodename = Qnil;
08114     }
08115     return lib_toUTF8_core(Qnil, str, encodename);
08116 }
08117 
08118 static VALUE
08119 ip_toUTF8(argc, argv, self)
08120     int   argc;
08121     VALUE *argv;
08122     VALUE self;
08123 {
08124     VALUE str, encodename;
08125 
08126     if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08127         encodename = Qnil;
08128     }
08129     return lib_toUTF8_core(self, str, encodename);
08130 }
08131 
08132 static VALUE
08133 lib_fromUTF8_core(ip_obj, src, encodename)
08134     VALUE ip_obj;
08135     VALUE src;
08136     VALUE encodename;
08137 {
08138     volatile VALUE str = src;
08139 
08140 #ifdef TCL_UTF_MAX
08141     Tcl_Interp *interp;
08142     Tcl_Encoding encoding;
08143     Tcl_DString dstr;
08144     int taint_flag = OBJ_TAINTED(str);
08145     char *buf;
08146     int thr_crit_bup;
08147 #endif
08148 
08149     tcl_stubs_check();
08150 
08151     if (NIL_P(src)) {
08152       return rb_str_new2("");
08153     }
08154 
08155 #ifdef TCL_UTF_MAX
08156     if (NIL_P(ip_obj)) {
08157         interp = (Tcl_Interp *)NULL;
08158     } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
08159         interp = (Tcl_Interp *)NULL;
08160     } else {
08161         interp = get_ip(ip_obj)->ip;
08162     }
08163 
08164     thr_crit_bup = rb_thread_critical;
08165     rb_thread_critical = Qtrue;
08166 
08167     if (NIL_P(encodename)) {
08168         volatile VALUE enc;
08169 
08170         if (TYPE(str) == T_STRING) {
08171             enc = rb_attr_get(str, ID_at_enc);
08172             if (!NIL_P(enc)) {
08173                 StringValue(enc);
08174                 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
08175 #ifdef HAVE_RUBY_ENCODING_H
08176                     rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08177 #endif
08178                     rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08179                     rb_thread_critical = thr_crit_bup;
08180                     return str;
08181                 }
08182 #ifdef HAVE_RUBY_ENCODING_H
08183             } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
08184                 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08185                 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08186                 rb_thread_critical = thr_crit_bup;
08187                 return str;
08188 #endif
08189             }
08190         }
08191 
08192         if (NIL_P(ip_obj)) {
08193             encoding = (Tcl_Encoding)NULL;
08194         } else {
08195             enc = rb_attr_get(ip_obj, ID_at_enc);
08196             if (NIL_P(enc)) {
08197                 encoding = (Tcl_Encoding)NULL;
08198             } else {
08199                 /* StringValue(enc); */
08200                 enc = rb_funcall(enc, ID_to_s, 0, 0);
08201                 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
08202                 if (!RSTRING_LEN(enc)) {
08203                   encoding = (Tcl_Encoding)NULL;
08204                 } else {
08205                   encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08206                                              RSTRING_PTR(enc));
08207                   if (encoding == (Tcl_Encoding)NULL) {
08208                     rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08209                   } else {
08210                     encodename = rb_obj_dup(enc);
08211                   }
08212                 }
08213             }
08214         }
08215 
08216     } else {
08217         StringValue(encodename);
08218 
08219         if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
08220             Tcl_Obj *tclstr;
08221             char *s;
08222             int  len;
08223 
08224             StringValue(str);
08225             tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str));
08226             Tcl_IncrRefCount(tclstr);
08227             s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len);
08228             str = rb_tainted_str_new(s, len);
08229             s = (char*)NULL;
08230             Tcl_DecrRefCount(tclstr);
08231 #ifdef HAVE_RUBY_ENCODING_H
08232             rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08233 #endif
08234             rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08235 
08236             rb_thread_critical = thr_crit_bup;
08237             return str;
08238         }
08239 
08240         /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
08241         encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
08242         if (encoding == (Tcl_Encoding)NULL) {
08243             /*
08244             rb_warning("unknown encoding name '%s'",
08245                        RSTRING_PTR(encodename));
08246             encodename = Qnil;
08247             */
08248             rb_raise(rb_eArgError, "unknown encoding name '%s'",
08249                      RSTRING_PTR(encodename));
08250         }
08251     }
08252 
08253     StringValue(str);
08254 
08255     if (RSTRING_LEN(str) == 0) {
08256         rb_thread_critical = thr_crit_bup;
08257         return rb_tainted_str_new2("");
08258     }
08259 
08260     buf = ALLOC_N(char, RSTRING_LEN(str)+1);
08261     /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
08262     memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
08263     buf[RSTRING_LEN(str)] = 0;
08264 
08265     Tcl_DStringInit(&dstr);
08266     Tcl_DStringFree(&dstr);
08267     /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */
08268     Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr);
08269 
08270     /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
08271     /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
08272     str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
08273 #ifdef HAVE_RUBY_ENCODING_H
08274     if (interp) {
08275       /* can access encoding_table of TclTkIp */
08276       /*   ->  try to use encoding_table      */
08277       VALUE tbl = ip_get_encoding_table(ip_obj);
08278       VALUE encobj = encoding_table_get_obj(tbl, encodename);
08279       rb_enc_associate_index(str, rb_to_encoding_index(encobj));
08280     } else {
08281       /* cannot access encoding_table of TclTkIp */
08282       /*   ->  try to find on Ruby Encoding      */
08283       rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename)));
08284     }
08285 #endif
08286 
08287     if (taint_flag) RbTk_OBJ_UNTRUST(str);
08288     rb_ivar_set(str, ID_at_enc, encodename);
08289 
08290     /*
08291     if (encoding != (Tcl_Encoding)NULL) {
08292         Tcl_FreeEncoding(encoding);
08293     }
08294     */
08295     Tcl_DStringFree(&dstr);
08296 
08297     xfree(buf);
08298     /* ckfree(buf); */
08299 
08300     rb_thread_critical = thr_crit_bup;
08301 #endif
08302 
08303     return str;
08304 }
08305 
08306 static VALUE
08307 lib_fromUTF8(argc, argv, self)
08308     int   argc;
08309     VALUE *argv;
08310     VALUE self;
08311 {
08312     VALUE str, encodename;
08313 
08314     if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08315         encodename = Qnil;
08316     }
08317     return lib_fromUTF8_core(Qnil, str, encodename);
08318 }
08319 
08320 static VALUE
08321 ip_fromUTF8(argc, argv, self)
08322     int   argc;
08323     VALUE *argv;
08324     VALUE self;
08325 {
08326     VALUE str, encodename;
08327 
08328     if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08329         encodename = Qnil;
08330     }
08331     return lib_fromUTF8_core(self, str, encodename);
08332 }
08333 
08334 static VALUE
08335 lib_UTF_backslash_core(self, str, all_bs)
08336     VALUE self;
08337     VALUE str;
08338     int all_bs;
08339 {
08340 #ifdef TCL_UTF_MAX
08341     char *src_buf, *dst_buf, *ptr;
08342     int read_len = 0, dst_len = 0;
08343     int taint_flag = OBJ_TAINTED(str);
08344     int thr_crit_bup;
08345 
08346     tcl_stubs_check();
08347 
08348     StringValue(str);
08349     if (!RSTRING_LEN(str)) {
08350         return str;
08351     }
08352 
08353     thr_crit_bup = rb_thread_critical;
08354     rb_thread_critical = Qtrue;
08355 
08356     /* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
08357     src_buf = ckalloc(RSTRING_LENINT(str)+1);
08358 #if 0 /* use Tcl_Preserve/Release */
08359     Tcl_Preserve((ClientData)src_buf); /* XXXXXXXX */
08360 #endif
08361     memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str));
08362     src_buf[RSTRING_LEN(str)] = 0;
08363 
08364     /* dst_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
08365     dst_buf = ckalloc(RSTRING_LENINT(str)+1);
08366 #if 0 /* use Tcl_Preserve/Release */
08367     Tcl_Preserve((ClientData)dst_buf); /* XXXXXXXX */
08368 #endif
08369 
08370     ptr = src_buf;
08371     while(RSTRING_LEN(str) > ptr - src_buf) {
08372         if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
08373             dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
08374             ptr += read_len;
08375         } else {
08376             *(dst_buf + (dst_len++)) = *(ptr++);
08377         }
08378     }
08379 
08380     str = rb_str_new(dst_buf, dst_len);
08381     if (taint_flag) RbTk_OBJ_UNTRUST(str);
08382 #ifdef HAVE_RUBY_ENCODING_H
08383     rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
08384 #endif
08385     rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
08386 
08387 #if 0 /* use Tcl_EventuallyFree */
08388     Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC); /* XXXXXXXX */
08389 #else
08390 #if 0 /* use Tcl_Preserve/Release */
08391     Tcl_Release((ClientData)src_buf); /* XXXXXXXX */
08392 #else
08393     /* free(src_buf); */
08394     ckfree(src_buf);
08395 #endif
08396 #endif
08397 #if 0 /* use Tcl_EventuallyFree */
08398     Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */
08399 #else
08400 #if 0 /* use Tcl_Preserve/Release */
08401     Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */
08402 #else
08403     /* free(dst_buf); */
08404     ckfree(dst_buf);
08405 #endif
08406 #endif
08407 
08408     rb_thread_critical = thr_crit_bup;
08409 #endif
08410 
08411     return str;
08412 }
08413 
08414 static VALUE
08415 lib_UTF_backslash(self, str)
08416     VALUE self;
08417     VALUE str;
08418 {
08419     return lib_UTF_backslash_core(self, str, 0);
08420 }
08421 
08422 static VALUE
08423 lib_Tcl_backslash(self, str)
08424     VALUE self;
08425     VALUE str;
08426 {
08427     return lib_UTF_backslash_core(self, str, 1);
08428 }
08429 
08430 static VALUE
08431 lib_get_system_encoding(self)
08432     VALUE self;
08433 {
08434 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
08435     tcl_stubs_check();
08436     return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
08437 #else
08438     return Qnil;
08439 #endif
08440 }
08441 
08442 static VALUE
08443 lib_set_system_encoding(self, enc_name)
08444     VALUE self;
08445     VALUE enc_name;
08446 {
08447 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
08448     tcl_stubs_check();
08449 
08450     if (NIL_P(enc_name)) {
08451         Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL);
08452         return lib_get_system_encoding(self);
08453     }
08454 
08455     enc_name = rb_funcall(enc_name, ID_to_s, 0, 0);
08456     if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL,
08457                               StringValuePtr(enc_name)) != TCL_OK) {
08458         rb_raise(rb_eArgError, "unknown encoding name '%s'",
08459                  RSTRING_PTR(enc_name));
08460     }
08461 
08462     return enc_name;
08463 #else
08464     return Qnil;
08465 #endif
08466 }
08467 
08468 
08469 /* invoke Tcl proc */
08470 struct invoke_info {
08471     struct tcltkip *ptr;
08472     Tcl_CmdInfo cmdinfo;
08473 #if TCL_MAJOR_VERSION >= 8
08474     int objc;
08475     Tcl_Obj **objv;
08476 #else
08477     int argc;
08478     char **argv;
08479 #endif
08480 };
08481 
08482 static VALUE
08483 #ifdef HAVE_PROTOTYPES
08484 invoke_tcl_proc(VALUE arg)
08485 #else
08486 invoke_tcl_proc(arg)
08487     VALUE arg;
08488 #endif
08489 {
08490     struct invoke_info *inf = (struct invoke_info *)arg;
08491     int i, len;
08492 #if TCL_MAJOR_VERSION >= 8
08493     int argc = inf->objc;
08494     char **argv = (char **)NULL;
08495 #endif
08496 
08497     /* memory allocation for arguments of this command */
08498 #if TCL_MAJOR_VERSION >= 8
08499     if (!inf->cmdinfo.isNativeObjectProc) {
08500         /* string interface */
08501         /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */
08502         argv = RbTk_ALLOC_N(char *, (argc+1));
08503 #if 0 /* use Tcl_Preserve/Release */
08504         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
08505 #endif
08506         for (i = 0; i < argc; ++i) {
08507             argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len);
08508         }
08509         argv[argc] = (char *)NULL;
08510     }
08511 #endif
08512 
08513     Tcl_ResetResult(inf->ptr->ip);
08514 
08515     /* Invoke the C procedure */
08516 #if TCL_MAJOR_VERSION >= 8
08517     if (inf->cmdinfo.isNativeObjectProc) {
08518         inf->ptr->return_value
08519             = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData,
08520                                         inf->ptr->ip, inf->objc, inf->objv);
08521     }
08522     else
08523 #endif
08524     {
08525 #if TCL_MAJOR_VERSION >= 8
08526         inf->ptr->return_value
08527             = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
08528                                      argc, (CONST84 char **)argv);
08529 
08530 #if 0 /* use Tcl_EventuallyFree */
08531     Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
08532 #else
08533 #if 0 /* use Tcl_Preserve/Release */
08534         Tcl_Release((ClientData)argv); /* XXXXXXXX */
08535 #else
08536         /* free(argv); */
08537         ckfree((char*)argv);
08538 #endif
08539 #endif
08540 
08541 #else /* TCL_MAJOR_VERSION < 8 */
08542         inf->ptr->return_value
08543             = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
08544                                      inf->argc, inf->argv);
08545 #endif
08546     }
08547 
08548     return Qnil;
08549 }
08550 
08551 
08552 #if TCL_MAJOR_VERSION >= 8
08553 static VALUE
08554 ip_invoke_core(interp, objc, objv)
08555     VALUE interp;
08556     int objc;
08557     Tcl_Obj **objv;
08558 #else
08559 static VALUE
08560 ip_invoke_core(interp, argc, argv)
08561     VALUE interp;
08562     int argc;
08563     char **argv;
08564 #endif
08565 {
08566     struct tcltkip *ptr;
08567     Tcl_CmdInfo info;
08568     char *cmd;
08569     int  len;
08570     int  thr_crit_bup;
08571     int unknown_flag = 0;
08572 
08573 #if 1 /* wrap tcl-proc call */
08574     struct invoke_info inf;
08575     int status;
08576     VALUE ret;
08577 #else
08578 #if TCL_MAJOR_VERSION >= 8
08579     int argc = objc;
08580     char **argv = (char **)NULL;
08581     /* Tcl_Obj *resultPtr; */
08582 #endif
08583 #endif
08584 
08585     /* get the data struct */
08586     ptr = get_ip(interp);
08587 
08588     /* get the command name string */
08589 #if TCL_MAJOR_VERSION >= 8
08590     cmd = Tcl_GetStringFromObj(objv[0], &len);
08591 #else /* TCL_MAJOR_VERSION < 8 */
08592     cmd = argv[0];
08593 #endif
08594 
08595     /* get the data struct */
08596     ptr = get_ip(interp);
08597 
08598     /* ip is deleted? */
08599     if (deleted_ip(ptr)) {
08600         return rb_tainted_str_new2("");
08601     }
08602 
08603     /* Tcl_Preserve(ptr->ip); */
08604     rbtk_preserve_ip(ptr);
08605 
08606     /* map from the command name to a C procedure */
08607     DUMP2("call Tcl_GetCommandInfo, %s", cmd);
08608     if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
08609         DUMP1("error Tcl_GetCommandInfo");
08610         DUMP1("try auto_load (call 'unknown' command)");
08611         if (!Tcl_GetCommandInfo(ptr->ip,
08612 #if TCL_MAJOR_VERSION >= 8
08613                                 "::unknown",
08614 #else
08615                                 "unknown",
08616 #endif
08617                                 &info)) {
08618             DUMP1("fail to get 'unknown' command");
08619             /* if (event_loop_abort_on_exc || cmd[0] != '.') { */
08620             if (event_loop_abort_on_exc > 0) {
08621                 /* Tcl_Release(ptr->ip); */
08622                 rbtk_release_ip(ptr);
08623                 /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
08624                 return create_ip_exc(interp, rb_eNameError,
08625                                      "invalid command name `%s'", cmd);
08626             } else {
08627                 if (event_loop_abort_on_exc < 0) {
08628                     rb_warning("invalid command name `%s' (ignore)", cmd);
08629                 } else {
08630                     rb_warn("invalid command name `%s' (ignore)", cmd);
08631                 }
08632                 Tcl_ResetResult(ptr->ip);
08633                 /* Tcl_Release(ptr->ip); */
08634                 rbtk_release_ip(ptr);
08635                 return rb_tainted_str_new2("");
08636             }
08637         } else {
08638 #if TCL_MAJOR_VERSION >= 8
08639             Tcl_Obj **unknown_objv;
08640 #else
08641             char **unknown_argv;
08642 #endif
08643             DUMP1("find 'unknown' command -> set arguemnts");
08644             unknown_flag = 1;
08645 
08646 #if TCL_MAJOR_VERSION >= 8
08647             /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */
08648             unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2));
08649 #if 0 /* use Tcl_Preserve/Release */
08650             Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */
08651 #endif
08652             unknown_objv[0] = Tcl_NewStringObj("::unknown", 9);
08653             Tcl_IncrRefCount(unknown_objv[0]);
08654             memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc);
08655             unknown_objv[++objc] = (Tcl_Obj*)NULL;
08656             objv = unknown_objv;
08657 #else
08658             /* unknown_argv = (char **)ALLOC_N(char *, argc+2); */
08659             unknown_argv = RbTk_ALLOC_N(char *, (argc+2));
08660 #if 0 /* use Tcl_Preserve/Release */
08661             Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */
08662 #endif
08663             unknown_argv[0] = strdup("unknown");
08664             memcpy(unknown_argv + 1, argv, sizeof(char *)*argc);
08665             unknown_argv[++argc] = (char *)NULL;
08666             argv = unknown_argv;
08667 #endif
08668         }
08669     }
08670     DUMP1("end Tcl_GetCommandInfo");
08671 
08672     thr_crit_bup = rb_thread_critical;
08673     rb_thread_critical = Qtrue;
08674 
08675 #if 1 /* wrap tcl-proc call */
08676     /* setup params */
08677     inf.ptr = ptr;
08678     inf.cmdinfo = info;
08679 #if TCL_MAJOR_VERSION >= 8
08680     inf.objc = objc;
08681     inf.objv = objv;
08682 #else
08683     inf.argc = argc;
08684     inf.argv = argv;
08685 #endif
08686 
08687     /* invoke tcl-proc */
08688     ret = rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
08689     switch(status) {
08690     case TAG_RAISE:
08691         if (NIL_P(rb_errinfo())) {
08692             rbtk_pending_exception = rb_exc_new2(rb_eException,
08693                                                  "unknown exception");
08694         } else {
08695             rbtk_pending_exception = rb_errinfo();
08696         }
08697         break;
08698 
08699     case TAG_FATAL:
08700         if (NIL_P(rb_errinfo())) {
08701             rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
08702         } else {
08703             rbtk_pending_exception = rb_errinfo();
08704         }
08705     }
08706 
08707 #else /* !wrap tcl-proc call */
08708 
08709     /* memory allocation for arguments of this command */
08710 #if TCL_MAJOR_VERSION >= 8
08711     if (!info.isNativeObjectProc) {
08712         int i;
08713 
08714         /* string interface */
08715         /* argv = (char **)ALLOC_N(char *, argc+1); */
08716         argv = RbTk_ALLOC_N(char *, (argc+1));
08717 #if 0 /* use Tcl_Preserve/Release */
08718         Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
08719 #endif
08720         for (i = 0; i < argc; ++i) {
08721             argv[i] = Tcl_GetStringFromObj(objv[i], &len);
08722         }
08723         argv[argc] = (char *)NULL;
08724     }
08725 #endif
08726 
08727     Tcl_ResetResult(ptr->ip);
08728 
08729     /* Invoke the C procedure */
08730 #if TCL_MAJOR_VERSION >= 8
08731     if (info.isNativeObjectProc) {
08732         ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip,
08733                                             objc, objv);
08734 #if 0
08735         /* get the string value from the result object */
08736         resultPtr = Tcl_GetObjResult(ptr->ip);
08737         Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
08738                       TCL_VOLATILE);
08739 #endif
08740     }
08741     else
08742 #endif
08743     {
08744 #if TCL_MAJOR_VERSION >= 8
08745         ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
08746                                          argc, (CONST84 char **)argv);
08747 
08748 #if 0 /* use Tcl_EventuallyFree */
08749     Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
08750 #else
08751 #if 0 /* use Tcl_Preserve/Release */
08752         Tcl_Release((ClientData)argv); /* XXXXXXXX */
08753 #else
08754         /* free(argv); */
08755         ckfree((char*)argv);
08756 #endif
08757 #endif
08758 
08759 #else /* TCL_MAJOR_VERSION < 8 */
08760         ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
08761                                          argc, argv);
08762 #endif
08763     }
08764 #endif /* ! wrap tcl-proc call */
08765 
08766     /* free allocated memory for calling 'unknown' command */
08767     if (unknown_flag) {
08768 #if TCL_MAJOR_VERSION >= 8
08769         Tcl_DecrRefCount(objv[0]);
08770 #if 0 /* use Tcl_EventuallyFree */
08771         Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */
08772 #else
08773 #if 0 /* use Tcl_Preserve/Release */
08774         Tcl_Release((ClientData)objv); /* XXXXXXXX */
08775 #else
08776         /* free(objv); */
08777         ckfree((char*)objv);
08778 #endif
08779 #endif
08780 #else /* TCL_MAJOR_VERSION < 8 */
08781         free(argv[0]);
08782         /* ckfree(argv[0]); */
08783 #if 0 /* use Tcl_EventuallyFree */
08784         Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
08785 #else
08786 #if 0 /* use Tcl_Preserve/Release */
08787         Tcl_Release((ClientData)argv); /* XXXXXXXX */
08788 #else
08789         /* free(argv); */
08790         ckfree((char*)argv);
08791 #endif
08792 #endif
08793 #endif
08794     }
08795 
08796     /* exception on mainloop */
08797     if (pending_exception_check1(thr_crit_bup, ptr)) {
08798         return rbtk_pending_exception;
08799     }
08800 
08801     rb_thread_critical = thr_crit_bup;
08802 
08803     /* if (ptr->return_value == TCL_ERROR) { */
08804     if (ptr->return_value != TCL_OK) {
08805         if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
08806             switch (ptr->return_value) {
08807             case TCL_RETURN:
08808               return create_ip_exc(interp, eTkCallbackReturn,
08809                                    "ip_invoke_core receives TCL_RETURN");
08810             case TCL_BREAK:
08811               return create_ip_exc(interp, eTkCallbackBreak,
08812                                    "ip_invoke_core receives TCL_BREAK");
08813             case TCL_CONTINUE:
08814               return create_ip_exc(interp, eTkCallbackContinue,
08815                                    "ip_invoke_core receives TCL_CONTINUE");
08816             default:
08817               return create_ip_exc(interp, rb_eRuntimeError, "%s",
08818                                    Tcl_GetStringResult(ptr->ip));
08819             }
08820 
08821         } else {
08822             if (event_loop_abort_on_exc < 0) {
08823                 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
08824             } else {
08825                 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
08826             }
08827             Tcl_ResetResult(ptr->ip);
08828             return rb_tainted_str_new2("");
08829         }
08830     }
08831 
08832     /* pass back the result (as string) */
08833     return ip_get_result_string_obj(ptr->ip);
08834 }
08835 
08836 
08837 #if TCL_MAJOR_VERSION >= 8
08838 static Tcl_Obj **
08839 #else /* TCL_MAJOR_VERSION < 8 */
08840 static char **
08841 #endif
08842 alloc_invoke_arguments(argc, argv)
08843     int argc;
08844     VALUE *argv;
08845 {
08846     int i;
08847     int thr_crit_bup;
08848 
08849 #if TCL_MAJOR_VERSION >= 8
08850     Tcl_Obj **av;
08851 #else /* TCL_MAJOR_VERSION < 8 */
08852     char **av;
08853 #endif
08854 
08855     thr_crit_bup = rb_thread_critical;
08856     rb_thread_critical = Qtrue;
08857 
08858     /* memory allocation */
08859 #if TCL_MAJOR_VERSION >= 8
08860     /* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */
08861     av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1));
08862 #if 0 /* use Tcl_Preserve/Release */
08863     Tcl_Preserve((ClientData)av); /* XXXXXXXX */
08864 #endif
08865     for (i = 0; i < argc; ++i) {
08866         av[i] = get_obj_from_str(argv[i]);
08867         Tcl_IncrRefCount(av[i]);
08868     }
08869     av[argc] = NULL;
08870 
08871 #else /* TCL_MAJOR_VERSION < 8 */
08872     /* string interface */
08873     /* av = ALLOC_N(char *, argc+1); */
08874     av = RbTk_ALLOC_N(char *, (argc+1));
08875 #if 0 /* use Tcl_Preserve/Release */
08876     Tcl_Preserve((ClientData)av); /* XXXXXXXX */
08877 #endif
08878     for (i = 0; i < argc; ++i) {
08879         av[i] = strdup(StringValuePtr(argv[i]));
08880     }
08881     av[argc] = NULL;
08882 #endif
08883 
08884     rb_thread_critical = thr_crit_bup;
08885 
08886     return av;
08887 }
08888 
08889 static void
08890 free_invoke_arguments(argc, av)
08891     int argc;
08892 #if TCL_MAJOR_VERSION >= 8
08893     Tcl_Obj **av;
08894 #else /* TCL_MAJOR_VERSION < 8 */
08895     char **av;
08896 #endif
08897 {
08898     int i;
08899 
08900     for (i = 0; i < argc; ++i) {
08901 #if TCL_MAJOR_VERSION >= 8
08902         Tcl_DecrRefCount(av[i]);
08903         av[i] = (Tcl_Obj*)NULL;
08904 #else /* TCL_MAJOR_VERSION < 8 */
08905         free(av[i]);
08906         av[i] = (char*)NULL;
08907 #endif
08908     }
08909 #if TCL_MAJOR_VERSION >= 8
08910 #if 0 /* use Tcl_EventuallyFree */
08911     Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
08912 #else
08913 #if 0 /* use Tcl_Preserve/Release */
08914     Tcl_Release((ClientData)av); /* XXXXXXXX */
08915 #else
08916     ckfree((char*)av);
08917 #endif
08918 #endif
08919 #else /* TCL_MAJOR_VERSION < 8 */
08920 #if 0 /* use Tcl_EventuallyFree */
08921     Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
08922 #else
08923 #if 0 /* use Tcl_Preserve/Release */
08924     Tcl_Release((ClientData)av); /* XXXXXXXX */
08925 #else
08926     /* free(av); */
08927     ckfree((char*)av);
08928 #endif
08929 #endif
08930 #endif
08931 }
08932 
08933 static VALUE
08934 ip_invoke_real(argc, argv, interp)
08935     int argc;
08936     VALUE *argv;
08937     VALUE interp;
08938 {
08939     VALUE v;
08940     struct tcltkip *ptr;        /* tcltkip data struct */
08941 
08942 #if TCL_MAJOR_VERSION >= 8
08943     Tcl_Obj **av = (Tcl_Obj **)NULL;
08944 #else /* TCL_MAJOR_VERSION < 8 */
08945     char **av = (char **)NULL;
08946 #endif
08947 
08948     DUMP2("invoke_real called by thread:%lx", rb_thread_current());
08949 
08950     /* get the data struct */
08951     ptr = get_ip(interp);
08952 
08953     /* ip is deleted? */
08954     if (deleted_ip(ptr)) {
08955         return rb_tainted_str_new2("");
08956     }
08957 
08958     /* allocate memory for arguments */
08959     av = alloc_invoke_arguments(argc, argv);
08960 
08961     /* Invoke the C procedure */
08962     Tcl_ResetResult(ptr->ip);
08963     v = ip_invoke_core(interp, argc, av);
08964 
08965     /* free allocated memory */
08966     free_invoke_arguments(argc, av);
08967 
08968     return v;
08969 }
08970 
08971 VALUE
08972 ivq_safelevel_handler(arg, ivq)
08973     VALUE arg;
08974     VALUE ivq;
08975 {
08976     struct invoke_queue *q;
08977 
08978     Data_Get_Struct(ivq, struct invoke_queue, q);
08979     DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
08980     rb_set_safe_level(q->safe_level);
08981     return ip_invoke_core(q->interp, q->argc, q->argv);
08982 }
08983 
08984 int invoke_queue_handler _((Tcl_Event *, int));
08985 int
08986 invoke_queue_handler(evPtr, flags)
08987     Tcl_Event *evPtr;
08988     int flags;
08989 {
08990     struct invoke_queue *q = (struct invoke_queue *)evPtr;
08991     volatile VALUE ret;
08992     volatile VALUE q_dat;
08993     volatile VALUE thread = q->thread;
08994     struct tcltkip *ptr;
08995 
08996     DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
08997     DUMP2("invoke queue_thread : %lx", rb_thread_current());
08998     DUMP2("added by thread : %lx", thread);
08999 
09000     if (*(q->done)) {
09001         DUMP1("processed by another event-loop");
09002         return 0;
09003     } else {
09004         DUMP1("process it on current event-loop");
09005     }
09006 
09007 #ifdef RUBY_VM
09008     if (RTEST(rb_funcall(thread, ID_alive_p, 0))
09009         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
09010 #else
09011     if (RTEST(rb_thread_alive_p(thread))
09012         && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
09013 #endif
09014       DUMP1("caller is not yet ready to receive the result -> pending");
09015       return 0;
09016     }
09017 
09018     /* process it */
09019     *(q->done) = 1;
09020 
09021     /* deleted ipterp ? */
09022     ptr = get_ip(q->interp);
09023     if (deleted_ip(ptr)) {
09024         /* deleted IP --> ignore */
09025         return 1;
09026     }
09027 
09028     /* incr internal handler mark */
09029     rbtk_internal_eventloop_handler++;
09030 
09031     /* check safe-level */
09032     if (rb_safe_level() != q->safe_level) {
09033         /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
09034         q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,-1,q);
09035         ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat),
09036                          ID_call, 0);
09037         rb_gc_force_recycle(q_dat);
09038         q_dat = (VALUE)NULL;
09039     } else {
09040         DUMP2("call invoke_real (for caller thread:%lx)", thread);
09041         DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
09042         ret = ip_invoke_core(q->interp, q->argc, q->argv);
09043     }
09044 
09045     /* set result */
09046     RARRAY_PTR(q->result)[0] = ret;
09047     ret = (VALUE)NULL;
09048 
09049     /* decr internal handler mark */
09050     rbtk_internal_eventloop_handler--;
09051 
09052     /* complete */
09053     *(q->done) = -1;
09054 
09055     /* unlink ruby objects */
09056     q->interp = (VALUE)NULL;
09057     q->result = (VALUE)NULL;
09058     q->thread = (VALUE)NULL;
09059 
09060     /* back to caller */
09061 #ifdef RUBY_VM
09062     if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
09063 #else
09064     if (RTEST(rb_thread_alive_p(thread))) {
09065 #endif
09066       DUMP2("back to caller (caller thread:%lx)", thread);
09067       DUMP2("               (current thread:%lx)", rb_thread_current());
09068 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
09069       have_rb_thread_waiting_for_value = 1;
09070       rb_thread_wakeup(thread);
09071 #else
09072       rb_thread_run(thread);
09073 #endif
09074       DUMP1("finish back to caller");
09075 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
09076       rb_thread_schedule();
09077 #endif
09078     } else {
09079       DUMP2("caller is dead (caller thread:%lx)", thread);
09080       DUMP2("               (current thread:%lx)", rb_thread_current());
09081     }
09082 
09083     /* end of handler : remove it */
09084     return 1;
09085 }
09086 
09087 static VALUE
09088 ip_invoke_with_position(argc, argv, obj, position)
09089     int argc;
09090     VALUE *argv;
09091     VALUE obj;
09092     Tcl_QueuePosition position;
09093 {
09094     struct invoke_queue *ivq;
09095 #ifdef RUBY_USE_NATIVE_THREAD
09096     struct tcltkip *ptr;
09097 #endif
09098     int  *alloc_done;
09099     int  thr_crit_bup;
09100     volatile VALUE current = rb_thread_current();
09101     volatile VALUE ip_obj = obj;
09102     volatile VALUE result;
09103     volatile VALUE ret;
09104     struct timeval t;
09105 
09106 #if TCL_MAJOR_VERSION >= 8
09107     Tcl_Obj **av = (Tcl_Obj **)NULL;
09108 #else /* TCL_MAJOR_VERSION < 8 */
09109     char **av = (char **)NULL;
09110 #endif
09111 
09112     if (argc < 1) {
09113         rb_raise(rb_eArgError, "command name missing");
09114     }
09115 
09116 #ifdef RUBY_USE_NATIVE_THREAD
09117     ptr = get_ip(ip_obj);
09118     DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id);
09119     DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
09120 #else
09121     DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
09122 #endif
09123     DUMP2("status: eventloopt_thread %lx", eventloop_thread);
09124 
09125     if (
09126 #ifdef RUBY_USE_NATIVE_THREAD
09127         (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
09128         &&
09129 #endif
09130         (NIL_P(eventloop_thread) || current == eventloop_thread)
09131         ) {
09132         if (NIL_P(eventloop_thread)) {
09133             DUMP2("invoke from thread:%lx but no eventloop", current);
09134         } else {
09135             DUMP2("invoke from current eventloop %lx", current);
09136         }
09137         result = ip_invoke_real(argc, argv, ip_obj);
09138         if (rb_obj_is_kind_of(result, rb_eException)) {
09139             rb_exc_raise(result);
09140         }
09141         return result;
09142     }
09143 
09144     DUMP2("invoke from thread %lx (NOT current eventloop)", current);
09145 
09146     thr_crit_bup = rb_thread_critical;
09147     rb_thread_critical = Qtrue;
09148 
09149     /* allocate memory (for arguments) */
09150     av = alloc_invoke_arguments(argc, argv);
09151 
09152     /* allocate memory (keep result) */
09153     /* alloc_done = (int*)ALLOC(int); */
09154     alloc_done = RbTk_ALLOC_N(int, 1);
09155 #if 0 /* use Tcl_Preserve/Release */
09156     Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
09157 #endif
09158     *alloc_done = 0;
09159 
09160     /* allocate memory (freed by Tcl_ServiceEvent) */
09161     /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */
09162     ivq = RbTk_ALLOC_N(struct invoke_queue, 1);
09163 #if 0 /* use Tcl_Preserve/Release */
09164     Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */
09165 #endif
09166 
09167     /* allocate result obj */
09168     result = rb_ary_new3(1, Qnil);
09169 
09170     /* construct event data */
09171     ivq->done = alloc_done;
09172     ivq->argc = argc;
09173     ivq->argv = av;
09174     ivq->interp = ip_obj;
09175     ivq->result = result;
09176     ivq->thread = current;
09177     ivq->safe_level = rb_safe_level();
09178     ivq->ev.proc = invoke_queue_handler;
09179 
09180     /* add the handler to Tcl event queue */
09181     DUMP1("add handler");
09182 #ifdef RUBY_USE_NATIVE_THREAD
09183     if (ptr->tk_thread_id) {
09184       /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */
09185       Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position);
09186       Tcl_ThreadAlert(ptr->tk_thread_id);
09187     } else if (tk_eventloop_thread_id) {
09188       /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
09189                            &(ivq->ev), position); */
09190       Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
09191                            (Tcl_Event*)ivq, position);
09192       Tcl_ThreadAlert(tk_eventloop_thread_id);
09193     } else {
09194       /* Tcl_QueueEvent(&(ivq->ev), position); */
09195       Tcl_QueueEvent((Tcl_Event*)ivq, position);
09196     }
09197 #else
09198     /* Tcl_QueueEvent(&(ivq->ev), position); */
09199     Tcl_QueueEvent((Tcl_Event*)ivq, position);
09200 #endif
09201 
09202     rb_thread_critical = thr_crit_bup;
09203 
09204     /* wait for the handler to be processed */
09205     t.tv_sec  = 0;
09206     t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
09207 
09208     DUMP2("ivq wait for handler (current thread:%lx)", current);
09209     while(*alloc_done >= 0) {
09210       /* rb_thread_stop(); */
09211       /* rb_thread_sleep_forever(); */
09212       rb_thread_wait_for(t);
09213       DUMP2("*** ivq wakeup (current thread:%lx)", current);
09214       DUMP2("***          (eventloop thread:%lx)", eventloop_thread);
09215       if (NIL_P(eventloop_thread)) {
09216         DUMP1("*** ivq lost eventloop thread");
09217         break;
09218       }
09219     }
09220     DUMP2("back from handler (current thread:%lx)", current);
09221 
09222     /* get result & free allocated memory */
09223     ret = RARRAY_PTR(result)[0];
09224 #if 0 /* use Tcl_EventuallyFree */
09225     Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
09226 #else
09227 #if 0 /* use Tcl_Preserve/Release */
09228     Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
09229 #else
09230     /* free(alloc_done); */
09231     ckfree((char*)alloc_done);
09232 #endif
09233 #endif
09234 
09235 #if 0 /* ivq is freed by Tcl_ServiceEvent */
09236 #if 0 /* use Tcl_EventuallyFree */
09237     Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */
09238 #else
09239 #if 0 /* use Tcl_Preserve/Release */
09240     Tcl_Release(ivq);
09241 #else
09242     ckfree((char*)ivq);
09243 #endif
09244 #endif
09245 #endif
09246 
09247     /* free allocated memory */
09248     free_invoke_arguments(argc, av);
09249 
09250     /* exception? */
09251     if (rb_obj_is_kind_of(ret, rb_eException)) {
09252         DUMP1("raise exception");
09253         /* rb_exc_raise(ret); */
09254         rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
09255                                  rb_funcall(ret, ID_to_s, 0, 0)));
09256     }
09257 
09258     DUMP1("exit ip_invoke");
09259     return ret;
09260 }
09261 
09262 
09263 /* get return code from Tcl_Eval() */
09264 static VALUE
09265 ip_retval(self)
09266     VALUE self;
09267 {
09268     struct tcltkip *ptr;        /* tcltkip data struct */
09269 
09270     /* get the data strcut */
09271     ptr = get_ip(self);
09272 
09273     /* ip is deleted? */
09274     if (deleted_ip(ptr)) {
09275         return rb_tainted_str_new2("");
09276     }
09277 
09278     return (INT2FIX(ptr->return_value));
09279 }
09280 
09281 static VALUE
09282 ip_invoke(argc, argv, obj)
09283     int argc;
09284     VALUE *argv;
09285     VALUE obj;
09286 {
09287     return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL);
09288 }
09289 
09290 static VALUE
09291 ip_invoke_immediate(argc, argv, obj)
09292     int argc;
09293     VALUE *argv;
09294     VALUE obj;
09295 {
09296     /* POTENTIALY INSECURE : can create infinite loop */
09297     rb_secure(4);
09298     return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
09299 }
09300 
09301 
09302 /* access Tcl variables */
09303 static VALUE
09304 ip_get_variable2_core(interp, argc, argv)
09305     VALUE interp;
09306     int   argc;
09307     VALUE *argv;
09308 {
09309     struct tcltkip *ptr = get_ip(interp);
09310     int thr_crit_bup;
09311     volatile VALUE varname, index, flag;
09312 
09313     varname = argv[0];
09314     index   = argv[1];
09315     flag    = argv[2];
09316 
09317     /*
09318     StringValue(varname);
09319     if (!NIL_P(index)) StringValue(index);
09320     */
09321 
09322 #if TCL_MAJOR_VERSION >= 8
09323     {
09324         Tcl_Obj *ret;
09325         volatile VALUE strval;
09326 
09327         thr_crit_bup = rb_thread_critical;
09328         rb_thread_critical = Qtrue;
09329 
09330         /* ip is deleted? */
09331         if (deleted_ip(ptr)) {
09332             rb_thread_critical = thr_crit_bup;
09333             return rb_tainted_str_new2("");
09334         } else {
09335             /* Tcl_Preserve(ptr->ip); */
09336             rbtk_preserve_ip(ptr);
09337             ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname),
09338                                 NIL_P(index) ? NULL : RSTRING_PTR(index),
09339                                 FIX2INT(flag));
09340         }
09341 
09342         if (ret == (Tcl_Obj*)NULL) {
09343             volatile VALUE exc;
09344             /* exc = rb_exc_new2(rb_eRuntimeError,
09345                                  Tcl_GetStringResult(ptr->ip)); */
09346             exc = create_ip_exc(interp, rb_eRuntimeError,
09347                                 Tcl_GetStringResult(ptr->ip));
09348             /* Tcl_Release(ptr->ip); */
09349             rbtk_release_ip(ptr);
09350             rb_thread_critical = thr_crit_bup;
09351             return exc;
09352         }
09353 
09354         Tcl_IncrRefCount(ret);
09355         strval = get_str_from_obj(ret);
09356         RbTk_OBJ_UNTRUST(strval);
09357         Tcl_DecrRefCount(ret);
09358 
09359         /* Tcl_Release(ptr->ip); */
09360         rbtk_release_ip(ptr);
09361         rb_thread_critical = thr_crit_bup;
09362         return(strval);
09363     }
09364 #else /* TCL_MAJOR_VERSION < 8 */
09365     {
09366         char *ret;
09367         volatile VALUE strval;
09368 
09369         /* ip is deleted? */
09370         if (deleted_ip(ptr)) {
09371             return rb_tainted_str_new2("");
09372         } else {
09373             /* Tcl_Preserve(ptr->ip); */
09374             rbtk_preserve_ip(ptr);
09375             ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname),
09376                               NIL_P(index) ? NULL : RSTRING_PTR(index),
09377                               FIX2INT(flag));
09378         }
09379 
09380         if (ret == (char*)NULL) {
09381             volatile VALUE exc;
09382             exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
09383             /* Tcl_Release(ptr->ip); */
09384             rbtk_release_ip(ptr);
09385             rb_thread_critical = thr_crit_bup;
09386             return exc;
09387         }
09388 
09389         strval = rb_tainted_str_new2(ret);
09390         /* Tcl_Release(ptr->ip); */
09391         rbtk_release_ip(ptr);
09392         rb_thread_critical = thr_crit_bup;
09393 
09394         return(strval);
09395     }
09396 #endif
09397 }
09398 
09399 static VALUE
09400 ip_get_variable2(self, varname, index, flag)
09401     VALUE self;
09402     VALUE varname;
09403     VALUE index;
09404     VALUE flag;
09405 {
09406     VALUE argv[3];
09407     VALUE retval;
09408 
09409     StringValue(varname);
09410     if (!NIL_P(index)) StringValue(index);
09411 
09412     argv[0] = varname;
09413     argv[1] = index;
09414     argv[2] = flag;
09415 
09416     retval = tk_funcall(ip_get_variable2_core, 3, argv, self);
09417 
09418     if (NIL_P(retval)) {
09419         return rb_tainted_str_new2("");
09420     } else {
09421         return retval;
09422     }
09423 }
09424 
09425 static VALUE
09426 ip_get_variable(self, varname, flag)
09427     VALUE self;
09428     VALUE varname;
09429     VALUE flag;
09430 {
09431     return ip_get_variable2(self, varname, Qnil, flag);
09432 }
09433 
09434 static VALUE
09435 ip_set_variable2_core(interp, argc, argv)
09436     VALUE interp;
09437     int   argc;
09438     VALUE *argv;
09439 {
09440     struct tcltkip *ptr = get_ip(interp);
09441     int thr_crit_bup;
09442     volatile VALUE varname, index, value, flag;
09443 
09444     varname = argv[0];
09445     index   = argv[1];
09446     value   = argv[2];
09447     flag    = argv[3];
09448 
09449     /*
09450     StringValue(varname);
09451     if (!NIL_P(index)) StringValue(index);
09452     StringValue(value);
09453     */
09454 
09455 #if TCL_MAJOR_VERSION >= 8
09456     {
09457         Tcl_Obj *valobj, *ret;
09458         volatile VALUE strval;
09459 
09460         thr_crit_bup = rb_thread_critical;
09461         rb_thread_critical = Qtrue;
09462 
09463         valobj = get_obj_from_str(value);
09464         Tcl_IncrRefCount(valobj);
09465 
09466         /* ip is deleted? */
09467         if (deleted_ip(ptr)) {
09468             Tcl_DecrRefCount(valobj);
09469             rb_thread_critical = thr_crit_bup;
09470             return rb_tainted_str_new2("");
09471         } else {
09472             /* Tcl_Preserve(ptr->ip); */
09473             rbtk_preserve_ip(ptr);
09474             ret = Tcl_SetVar2Ex(ptr->ip, RSTRING_PTR(varname),
09475                                 NIL_P(index) ? NULL : RSTRING_PTR(index),
09476                                 valobj, FIX2INT(flag));
09477         }
09478 
09479         Tcl_DecrRefCount(valobj);
09480 
09481         if (ret == (Tcl_Obj*)NULL) {
09482             volatile VALUE exc;
09483             /* exc = rb_exc_new2(rb_eRuntimeError,
09484                                  Tcl_GetStringResult(ptr->ip)); */
09485             exc = create_ip_exc(interp, rb_eRuntimeError,
09486                                 Tcl_GetStringResult(ptr->ip));
09487             /* Tcl_Release(ptr->ip); */
09488             rbtk_release_ip(ptr);
09489             rb_thread_critical = thr_crit_bup;
09490             return exc;
09491         }
09492 
09493         Tcl_IncrRefCount(ret);
09494         strval = get_str_from_obj(ret);
09495         RbTk_OBJ_UNTRUST(strval);
09496         Tcl_DecrRefCount(ret);
09497 
09498         /* Tcl_Release(ptr->ip); */
09499         rbtk_release_ip(ptr);
09500         rb_thread_critical = thr_crit_bup;
09501 
09502         return(strval);
09503     }
09504 #else /* TCL_MAJOR_VERSION < 8 */
09505     {
09506         CONST char *ret;
09507         volatile VALUE strval;
09508 
09509         /* ip is deleted? */
09510         if (deleted_ip(ptr)) {
09511             return rb_tainted_str_new2("");
09512         } else {
09513             /* Tcl_Preserve(ptr->ip); */
09514             rbtk_preserve_ip(ptr);
09515             ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname),
09516                               NIL_P(index) ? NULL : RSTRING_PTR(index),
09517                               RSTRING_PTR(value), FIX2INT(flag));
09518         }
09519 
09520         if (ret == (char*)NULL) {
09521             return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
09522         }
09523 
09524         strval = rb_tainted_str_new2(ret);
09525 
09526         /* Tcl_Release(ptr->ip); */
09527         rbtk_release_ip(ptr);
09528         rb_thread_critical = thr_crit_bup;
09529 
09530         return(strval);
09531     }
09532 #endif
09533 }
09534 
09535 static VALUE
09536 ip_set_variable2(self, varname, index, value, flag)
09537     VALUE self;
09538     VALUE varname;
09539     VALUE index;
09540     VALUE value;
09541     VALUE flag;
09542 {
09543     VALUE argv[4];
09544     VALUE retval;
09545 
09546     StringValue(varname);
09547     if (!NIL_P(index)) StringValue(index);
09548     StringValue(value);
09549 
09550     argv[0] = varname;
09551     argv[1] = index;
09552     argv[2] = value;
09553     argv[3] = flag;
09554 
09555     retval = tk_funcall(ip_set_variable2_core, 4, argv, self);
09556 
09557     if (NIL_P(retval)) {
09558         return rb_tainted_str_new2("");
09559     } else {
09560         return retval;
09561     }
09562 }
09563 
09564 static VALUE
09565 ip_set_variable(self, varname, value, flag)
09566     VALUE self;
09567     VALUE varname;
09568     VALUE value;
09569     VALUE flag;
09570 {
09571     return ip_set_variable2(self, varname, Qnil, value, flag);
09572 }
09573 
09574 static VALUE
09575 ip_unset_variable2_core(interp, argc, argv)
09576     VALUE interp;
09577     int   argc;
09578     VALUE *argv;
09579 {
09580     struct tcltkip *ptr = get_ip(interp);
09581     volatile VALUE varname, index, flag;
09582 
09583     varname = argv[0];
09584     index   = argv[1];
09585     flag    = argv[2];
09586 
09587     /*
09588     StringValue(varname);
09589     if (!NIL_P(index)) StringValue(index);
09590     */
09591 
09592     /* ip is deleted? */
09593     if (deleted_ip(ptr)) {
09594         return Qtrue;
09595     }
09596 
09597     ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname),
09598                                       NIL_P(index) ? NULL : RSTRING_PTR(index),
09599                                       FIX2INT(flag));
09600 
09601     if (ptr->return_value == TCL_ERROR) {
09602         if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
09603             /* return rb_exc_new2(rb_eRuntimeError,
09604                                   Tcl_GetStringResult(ptr->ip)); */
09605             return create_ip_exc(interp, rb_eRuntimeError,
09606                                  Tcl_GetStringResult(ptr->ip));
09607         }
09608         return Qfalse;
09609     }
09610     return Qtrue;
09611 }
09612 
09613 static VALUE
09614 ip_unset_variable2(self, varname, index, flag)
09615     VALUE self;
09616     VALUE varname;
09617     VALUE index;
09618     VALUE flag;
09619 {
09620     VALUE argv[3];
09621     VALUE retval;
09622 
09623     StringValue(varname);
09624     if (!NIL_P(index)) StringValue(index);
09625 
09626     argv[0] = varname;
09627     argv[1] = index;
09628     argv[2] = flag;
09629 
09630     retval = tk_funcall(ip_unset_variable2_core, 3, argv, self);
09631 
09632     if (NIL_P(retval)) {
09633         return rb_tainted_str_new2("");
09634     } else {
09635         return retval;
09636     }
09637 }
09638 
09639 static VALUE
09640 ip_unset_variable(self, varname, flag)
09641     VALUE self;
09642     VALUE varname;
09643     VALUE flag;
09644 {
09645     return ip_unset_variable2(self, varname, Qnil, flag);
09646 }
09647 
09648 static VALUE
09649 ip_get_global_var(self, varname)
09650     VALUE self;
09651     VALUE varname;
09652 {
09653     return ip_get_variable(self, varname,
09654                            INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09655 }
09656 
09657 static VALUE
09658 ip_get_global_var2(self, varname, index)
09659     VALUE self;
09660     VALUE varname;
09661     VALUE index;
09662 {
09663     return ip_get_variable2(self, varname, index,
09664                             INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09665 }
09666 
09667 static VALUE
09668 ip_set_global_var(self, varname, value)
09669     VALUE self;
09670     VALUE varname;
09671     VALUE value;
09672 {
09673     return ip_set_variable(self, varname, value,
09674                            INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09675 }
09676 
09677 static VALUE
09678 ip_set_global_var2(self, varname, index, value)
09679     VALUE self;
09680     VALUE varname;
09681     VALUE index;
09682     VALUE value;
09683 {
09684     return ip_set_variable2(self, varname, index, value,
09685                             INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09686 }
09687 
09688 static VALUE
09689 ip_unset_global_var(self, varname)
09690     VALUE self;
09691     VALUE varname;
09692 {
09693     return ip_unset_variable(self, varname,
09694                              INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09695 }
09696 
09697 static VALUE
09698 ip_unset_global_var2(self, varname, index)
09699     VALUE self;
09700     VALUE varname;
09701     VALUE index;
09702 {
09703     return ip_unset_variable2(self, varname, index,
09704                               INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09705 }
09706 
09707 
09708 /* treat Tcl_List */
09709 static VALUE
09710 lib_split_tklist_core(ip_obj, list_str)
09711     VALUE ip_obj;
09712     VALUE list_str;
09713 {
09714     Tcl_Interp *interp;
09715     volatile VALUE ary, elem;
09716     int idx;
09717     int taint_flag = OBJ_TAINTED(list_str);
09718 #ifdef HAVE_RUBY_ENCODING_H
09719     int list_enc_idx;
09720     volatile VALUE list_ivar_enc;
09721 #endif
09722     int result;
09723     VALUE old_gc;
09724 
09725     tcl_stubs_check();
09726 
09727     if (NIL_P(ip_obj)) {
09728         interp = (Tcl_Interp *)NULL;
09729     } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
09730         interp = (Tcl_Interp *)NULL;
09731     } else {
09732         interp = get_ip(ip_obj)->ip;
09733     }
09734 
09735     StringValue(list_str);
09736 #ifdef HAVE_RUBY_ENCODING_H
09737     list_enc_idx = rb_enc_get_index(list_str);
09738     list_ivar_enc = rb_ivar_get(list_str, ID_at_enc);
09739 #endif
09740 
09741     {
09742 #if TCL_MAJOR_VERSION >= 8
09743         /* object style interface */
09744         Tcl_Obj *listobj;
09745         int     objc;
09746         Tcl_Obj **objv;
09747         int thr_crit_bup;
09748 
09749         listobj = get_obj_from_str(list_str);
09750 
09751         Tcl_IncrRefCount(listobj);
09752 
09753         result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
09754 
09755         if (result == TCL_ERROR) {
09756             Tcl_DecrRefCount(listobj);
09757             if (interp == (Tcl_Interp*)NULL) {
09758                 rb_raise(rb_eRuntimeError, "can't get elements from list");
09759             } else {
09760                 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
09761             }
09762         }
09763 
09764         for(idx = 0; idx < objc; idx++) {
09765             Tcl_IncrRefCount(objv[idx]);
09766         }
09767 
09768         thr_crit_bup = rb_thread_critical;
09769         rb_thread_critical = Qtrue;
09770 
09771         ary = rb_ary_new2(objc);
09772         if (taint_flag) RbTk_OBJ_UNTRUST(ary);
09773 
09774         old_gc = rb_gc_disable();
09775 
09776         for(idx = 0; idx < objc; idx++) {
09777             elem = get_str_from_obj(objv[idx]);
09778             if (taint_flag) RbTk_OBJ_UNTRUST(elem);
09779 
09780 #ifdef HAVE_RUBY_ENCODING_H
09781             if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) {
09782                 rb_enc_associate_index(elem, ENCODING_INDEX_BINARY);
09783                 rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY);
09784             } else {
09785                 rb_enc_associate_index(elem, list_enc_idx);
09786                 rb_ivar_set(elem, ID_at_enc, list_ivar_enc);
09787             }
09788 #endif
09789             /* RARRAY(ary)->ptr[idx] = elem; */
09790             rb_ary_push(ary, elem);
09791         }
09792 
09793         /* RARRAY(ary)->len = objc; */
09794 
09795         if (old_gc == Qfalse) rb_gc_enable();
09796 
09797         rb_thread_critical = thr_crit_bup;
09798 
09799         for(idx = 0; idx < objc; idx++) {
09800             Tcl_DecrRefCount(objv[idx]);
09801         }
09802 
09803         Tcl_DecrRefCount(listobj);
09804 
09805 #else /* TCL_MAJOR_VERSION < 8 */
09806         /* string style interface */
09807         int  argc;
09808         char **argv;
09809 
09810         if (Tcl_SplitList(interp, RSTRING_PTR(list_str),
09811                           &argc, &argv) == TCL_ERROR) {
09812             if (interp == (Tcl_Interp*)NULL) {
09813                 rb_raise(rb_eRuntimeError, "can't get elements from list");
09814             } else {
09815                 rb_raise(rb_eRuntimeError, "%s", interp->result);
09816             }
09817         }
09818 
09819         ary = rb_ary_new2(argc);
09820         if (taint_flag) RbTk_OBJ_UNTRUST(ary);
09821 
09822         old_gc = rb_gc_disable();
09823 
09824         for(idx = 0; idx < argc; idx++) {
09825             if (taint_flag) {
09826                 elem = rb_tainted_str_new2(argv[idx]);
09827             } else {
09828                 elem = rb_str_new2(argv[idx]);
09829             }
09830             /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */
09831             /* RARRAY(ary)->ptr[idx] = elem; */
09832             rb_ary_push(ary, elem)
09833         }
09834         /* RARRAY(ary)->len = argc; */
09835 
09836         if (old_gc == Qfalse) rb_gc_enable();
09837 #endif
09838     }
09839 
09840     return ary;
09841 }
09842 
09843 static VALUE
09844 lib_split_tklist(self, list_str)
09845     VALUE self;
09846     VALUE list_str;
09847 {
09848     return lib_split_tklist_core(Qnil, list_str);
09849 }
09850 
09851 
09852 static VALUE
09853 ip_split_tklist(self, list_str)
09854     VALUE self;
09855     VALUE list_str;
09856 {
09857     return lib_split_tklist_core(self, list_str);
09858 }
09859 
09860 static VALUE
09861 lib_merge_tklist(argc, argv, obj)
09862     int argc;
09863     VALUE *argv;
09864     VALUE obj;
09865 {
09866     int  num, len;
09867     int  *flagPtr;
09868     char *dst, *result;
09869     volatile VALUE str;
09870     int taint_flag = 0;
09871     int thr_crit_bup;
09872     VALUE old_gc;
09873 
09874     if (argc == 0) return rb_str_new2("");
09875 
09876     tcl_stubs_check();
09877 
09878     thr_crit_bup = rb_thread_critical;
09879     rb_thread_critical = Qtrue;
09880     old_gc = rb_gc_disable();
09881 
09882     /* based on Tcl/Tk's Tcl_Merge() */
09883     /* flagPtr = ALLOC_N(int, argc); */
09884     flagPtr = RbTk_ALLOC_N(int, argc);
09885 #if 0 /* use Tcl_Preserve/Release */
09886     Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */
09887 #endif
09888 
09889     /* pass 1 */
09890     len = 1;
09891     for(num = 0; num < argc; num++) {
09892         if (OBJ_TAINTED(argv[num])) taint_flag = 1;
09893         dst = StringValuePtr(argv[num]);
09894 #if TCL_MAJOR_VERSION >= 8
09895         len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]),
09896                                       &flagPtr[num]) + 1;
09897 #else /* TCL_MAJOR_VERSION < 8 */
09898         len += Tcl_ScanElement(dst, &flagPtr[num]) + 1;
09899 #endif
09900     }
09901 
09902     /* pass 2 */
09903     /* result = (char *)Tcl_Alloc(len); */
09904     result = (char *)ckalloc(len);
09905 #if 0 /* use Tcl_Preserve/Release */
09906     Tcl_Preserve((ClientData)result);
09907 #endif
09908     dst = result;
09909     for(num = 0; num < argc; num++) {
09910 #if TCL_MAJOR_VERSION >= 8
09911         len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]),
09912                                         RSTRING_LENINT(argv[num]),
09913                                         dst, flagPtr[num]);
09914 #else /* TCL_MAJOR_VERSION < 8 */
09915         len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]);
09916 #endif
09917         dst += len;
09918         *dst = ' ';
09919         dst++;
09920     }
09921     if (dst == result) {
09922         *dst = 0;
09923     } else {
09924         dst[-1] = 0;
09925     }
09926 
09927 #if 0 /* use Tcl_EventuallyFree */
09928     Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */
09929 #else
09930 #if 0 /* use Tcl_Preserve/Release */
09931     Tcl_Release((ClientData)flagPtr);
09932 #else
09933     /* free(flagPtr); */
09934     ckfree((char*)flagPtr);
09935 #endif
09936 #endif
09937 
09938     /* create object */
09939     str = rb_str_new(result, dst - result - 1);
09940     if (taint_flag) RbTk_OBJ_UNTRUST(str);
09941 #if 0 /* use Tcl_EventuallyFree */
09942     Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC); /* XXXXXXXX */
09943 #else
09944 #if 0 /* use Tcl_Preserve/Release */
09945     Tcl_Release((ClientData)result); /* XXXXXXXXXXX */
09946 #else
09947     /* Tcl_Free(result); */
09948     ckfree(result);
09949 #endif
09950 #endif
09951 
09952     if (old_gc == Qfalse) rb_gc_enable();
09953     rb_thread_critical = thr_crit_bup;
09954 
09955     return str;
09956 }
09957 
09958 static VALUE
09959 lib_conv_listelement(self, src)
09960     VALUE self;
09961     VALUE src;
09962 {
09963     int   len, scan_flag;
09964     volatile VALUE dst;
09965     int   taint_flag = OBJ_TAINTED(src);
09966     int thr_crit_bup;
09967 
09968     tcl_stubs_check();
09969 
09970     thr_crit_bup = rb_thread_critical;
09971     rb_thread_critical = Qtrue;
09972 
09973     StringValue(src);
09974 
09975 #if TCL_MAJOR_VERSION >= 8
09976     len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
09977                                  &scan_flag);
09978     dst = rb_str_new(0, len + 1);
09979     len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
09980                                     RSTRING_PTR(dst), scan_flag);
09981 #else /* TCL_MAJOR_VERSION < 8 */
09982     len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag);
09983     dst = rb_str_new(0, len + 1);
09984     len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag);
09985 #endif
09986 
09987     rb_str_resize(dst, len);
09988     if (taint_flag) RbTk_OBJ_UNTRUST(dst);
09989 
09990     rb_thread_critical = thr_crit_bup;
09991 
09992     return dst;
09993 }
09994 
09995 static VALUE
09996 lib_getversion(self)
09997     VALUE self;
09998 {
09999     set_tcltk_version();
10000 
10001     return rb_ary_new3(4, INT2NUM(tcltk_version.major),
10002                           INT2NUM(tcltk_version.minor),
10003                           INT2NUM(tcltk_version.type),
10004                           INT2NUM(tcltk_version.patchlevel));
10005 }
10006 
10007 static VALUE
10008 lib_get_reltype_name(self)
10009     VALUE self;
10010 {
10011     set_tcltk_version();
10012 
10013     switch(tcltk_version.type) {
10014     case TCL_ALPHA_RELEASE:
10015       return rb_str_new2("alpha");
10016     case TCL_BETA_RELEASE:
10017       return rb_str_new2("beta");
10018     case TCL_FINAL_RELEASE:
10019       return rb_str_new2("final");
10020     default:
10021       rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number");
10022     }
10023 
10024     UNREACHABLE;
10025 }
10026 
10027 
10028 static VALUE
10029 tcltklib_compile_info()
10030 {
10031     volatile VALUE ret;
10032     size_t size;
10033     static CONST char form[]
10034       = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s";
10035     char *info;
10036 
10037     size = strlen(form)
10038         + strlen(TCLTKLIB_RELEASE_DATE)
10039         + strlen(RUBY_VERSION)
10040         + strlen(RUBY_RELEASE_DATE)
10041         + strlen("without")
10042         + strlen(TCL_PATCH_LEVEL)
10043         + strlen("without stub")
10044         + strlen(TK_PATCH_LEVEL)
10045         + strlen("without stub")
10046         + strlen("unknown tcl_threads");
10047 
10048     info = ALLOC_N(char, size);
10049     /* info = ckalloc(sizeof(char) * size); */ /* SEGV */
10050 
10051     sprintf(info, form,
10052             TCLTKLIB_RELEASE_DATE,
10053             RUBY_VERSION, RUBY_RELEASE_DATE,
10054 #ifdef HAVE_NATIVETHREAD
10055             "with",
10056 #else
10057             "without",
10058 #endif
10059             TCL_PATCH_LEVEL,
10060 #ifdef USE_TCL_STUBS
10061             "with stub",
10062 #else
10063             "without stub",
10064 #endif
10065             TK_PATCH_LEVEL,
10066 #ifdef USE_TK_STUBS
10067             "with stub",
10068 #else
10069             "without stub",
10070 #endif
10071 #ifdef WITH_TCL_ENABLE_THREAD
10072 # if WITH_TCL_ENABLE_THREAD
10073             "with tcl_threads"
10074 # else
10075             "without tcl_threads"
10076 # endif
10077 #else
10078             "unknown tcl_threads"
10079 #endif
10080         );
10081 
10082     ret = rb_obj_freeze(rb_str_new2(info));
10083 
10084     xfree(info);
10085     /* ckfree(info); */
10086 
10087     return ret;
10088 }
10089 
10090 
10091 /*###############################################*/
10092 
10093 static VALUE
10094 create_dummy_encoding_for_tk_core(interp, name, error_mode)
10095      VALUE interp;
10096      VALUE name;
10097      VALUE error_mode;
10098 {
10099   get_ip(interp);
10100 
10101   rb_secure(4);
10102 
10103   StringValue(name);
10104 
10105 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10106   if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) {
10107     if (RTEST(error_mode)) {
10108       rb_raise(rb_eArgError, "invalid Tk encoding name '%s'",
10109                RSTRING_PTR(name));
10110     } else {
10111       return Qnil;
10112     }
10113   }
10114 #endif
10115 
10116 #ifdef HAVE_RUBY_ENCODING_H
10117   if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) {
10118     int idx = rb_enc_find_index(StringValueCStr(name));
10119     return rb_enc_from_encoding(rb_enc_from_index(idx));
10120   } else {
10121     if (RTEST(error_mode)) {
10122       rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'",
10123                RSTRING_PTR(name));
10124     } else {
10125       return Qnil;
10126     }
10127   }
10128 
10129   UNREACHABLE;
10130 #else
10131     return name;
10132 #endif
10133 }
10134 static VALUE
10135 create_dummy_encoding_for_tk(interp, name)
10136      VALUE interp;
10137      VALUE name;
10138 {
10139   return create_dummy_encoding_for_tk_core(interp, name, Qtrue);
10140 }
10141 
10142 
10143 #ifdef HAVE_RUBY_ENCODING_H
10144 static int
10145 update_encoding_table(table, interp, error_mode)
10146      VALUE table;
10147      VALUE interp;
10148      VALUE error_mode;
10149 {
10150   struct tcltkip *ptr;
10151   int retry = 0;
10152   int i, idx, objc;
10153   Tcl_Obj **objv;
10154   Tcl_Obj *enc_list;
10155   volatile VALUE encname = Qnil;
10156   volatile VALUE encobj = Qnil;
10157 
10158   /* interpreter check */
10159   if (NIL_P(interp)) return 0;
10160   ptr = get_ip(interp);
10161   if (ptr == (struct tcltkip *) NULL)  return 0;
10162   if (deleted_ip(ptr)) return 0;
10163 
10164   /* get Tcl's encoding list */
10165   Tcl_GetEncodingNames(ptr->ip);
10166   enc_list = Tcl_GetObjResult(ptr->ip);
10167   Tcl_IncrRefCount(enc_list);
10168 
10169   if (Tcl_ListObjGetElements(ptr->ip, enc_list,
10170                              &objc, &objv) != TCL_OK) {
10171     Tcl_DecrRefCount(enc_list);
10172     /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");*/
10173     return 0;
10174   }
10175 
10176   /* check each encoding name */
10177   for(i = 0; i < objc; i++) {
10178     encname = rb_str_new2(Tcl_GetString(objv[i]));
10179     if (NIL_P(rb_hash_lookup(table, encname))) {
10180       /* new Tk encoding -> add to table */
10181       idx = rb_enc_find_index(StringValueCStr(encname));
10182       if (idx < 0) {
10183         encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode);
10184       } else {
10185         encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10186       }
10187       encname = rb_obj_freeze(encname);
10188       rb_hash_aset(table, encname, encobj);
10189       if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) {
10190         rb_hash_aset(table, encobj, encname);
10191       }
10192       retry = 1;
10193     }
10194   }
10195 
10196   Tcl_DecrRefCount(enc_list);
10197 
10198   return retry;
10199 }
10200 
10201 static VALUE
10202 encoding_table_get_name_core(table, enc_arg, error_mode)
10203      VALUE table;
10204      VALUE enc_arg;
10205      VALUE error_mode;
10206 {
10207   volatile VALUE enc = enc_arg;
10208   volatile VALUE name = Qnil;
10209   volatile VALUE tmp = Qnil;
10210   volatile VALUE interp = rb_ivar_get(table, ID_at_interp);
10211   struct tcltkip *ptr = (struct tcltkip *) NULL;
10212   int idx;
10213 
10214   /* deleted interp ? */
10215   if (!NIL_P(interp)) {
10216     ptr = get_ip(interp);
10217     if (deleted_ip(ptr)) {
10218       ptr = (struct tcltkip *) NULL;
10219     }
10220   }
10221 
10222   /* encoding argument check */
10223   /* 1st: default encoding setting of interp */
10224   if (ptr && NIL_P(enc)) {
10225     if (rb_respond_to(interp, ID_encoding_name)) {
10226       enc = rb_funcall(interp, ID_encoding_name, 0, 0);
10227     }
10228   }
10229   /* 2nd: Encoding.default_internal */
10230   if (NIL_P(enc)) {
10231     enc = rb_enc_default_internal();
10232   }
10233   /* 3rd: encoding system of Tcl/Tk */
10234   if (NIL_P(enc)) {
10235     enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
10236   }
10237   /* 4th: Encoding.default_external */
10238   if (NIL_P(enc)) {
10239     enc = rb_enc_default_external();
10240   }
10241   /* 5th: Encoding.locale_charmap */
10242   if (NIL_P(enc)) {
10243     enc = rb_locale_charmap(rb_cEncoding);
10244   }
10245 
10246   if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) {
10247     /* Ruby's Encoding object */
10248     name = rb_hash_lookup(table, enc);
10249     if (!NIL_P(name)) {
10250       /* find */
10251       return name;
10252     }
10253 
10254     /* is it new ? */
10255     /* update check of Tk encoding names */
10256     if (update_encoding_table(table, interp, error_mode)) {
10257       /* add new relations to the table   */
10258       /* RETRY: registered Ruby encoding? */
10259       name = rb_hash_lookup(table, enc);
10260       if (!NIL_P(name)) {
10261         /* find */
10262         return name;
10263       }
10264     }
10265     /* fail to find */
10266 
10267   } else {
10268     /* String or Symbol? */
10269     name = rb_funcall(enc, ID_to_s, 0, 0);
10270 
10271     if (!NIL_P(rb_hash_lookup(table, name))) {
10272       /* find */
10273       return name;
10274     }
10275 
10276     /* is it new ? */
10277     idx = rb_enc_find_index(StringValueCStr(name));
10278     if (idx >= 0) {
10279       enc = rb_enc_from_encoding(rb_enc_from_index(idx));
10280 
10281       /* registered Ruby encoding? */
10282       tmp = rb_hash_lookup(table, enc);
10283       if (!NIL_P(tmp)) {
10284         /* find */
10285         return tmp;
10286       }
10287 
10288       /* update check of Tk encoding names */
10289       if (update_encoding_table(table, interp, error_mode)) {
10290         /* add new relations to the table   */
10291         /* RETRY: registered Ruby encoding? */
10292         tmp = rb_hash_lookup(table, enc);
10293         if (!NIL_P(tmp)) {
10294           /* find */
10295           return tmp;
10296         }
10297       }
10298     }
10299     /* fail to find */
10300   }
10301 
10302   if (RTEST(error_mode)) {
10303     enc = rb_funcall(enc_arg, ID_to_s, 0, 0);
10304     rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10305   }
10306   return Qnil;
10307 }
10308 static VALUE
10309 encoding_table_get_obj_core(table, enc, error_mode)
10310      VALUE table;
10311      VALUE enc;
10312      VALUE error_mode;
10313 {
10314   volatile VALUE obj = Qnil;
10315 
10316   obj = rb_hash_lookup(table,
10317                        encoding_table_get_name_core(table, enc, error_mode));
10318   if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) {
10319     return obj;
10320   } else {
10321     return Qnil;
10322   }
10323 }
10324 
10325 #else /* ! HAVE_RUBY_ENCODING_H */
10326 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10327 static int
10328 update_encoding_table(table, interp, error_mode)
10329      VALUE table;
10330      VALUE interp;
10331      VALUE error_mode;
10332 {
10333   struct tcltkip *ptr;
10334   int retry = 0;
10335   int i, objc;
10336   Tcl_Obj **objv;
10337   Tcl_Obj *enc_list;
10338   volatile VALUE encname = Qnil;
10339 
10340   /* interpreter check */
10341   if (NIL_P(interp)) return 0;
10342   ptr = get_ip(interp);
10343   if (ptr == (struct tcltkip *) NULL)  return 0;
10344   if (deleted_ip(ptr)) return 0;
10345 
10346   /* get Tcl's encoding list */
10347   Tcl_GetEncodingNames(ptr->ip);
10348   enc_list = Tcl_GetObjResult(ptr->ip);
10349   Tcl_IncrRefCount(enc_list);
10350 
10351   if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10352     Tcl_DecrRefCount(enc_list);
10353     /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); */
10354     return 0;
10355   }
10356 
10357   /* get encoding name and set it to table */
10358   for(i = 0; i < objc; i++) {
10359     encname = rb_str_new2(Tcl_GetString(objv[i]));
10360     if (NIL_P(rb_hash_lookup(table, encname))) {
10361       /* new Tk encoding -> add to table */
10362       encname = rb_obj_freeze(encname);
10363       rb_hash_aset(table, encname, encname);
10364       retry = 1;
10365     }
10366   }
10367 
10368   Tcl_DecrRefCount(enc_list);
10369 
10370   return retry;
10371 }
10372 
10373 static VALUE
10374 encoding_table_get_name_core(table, enc, error_mode)
10375      VALUE table;
10376      VALUE enc;
10377      VALUE error_mode;
10378 {
10379   volatile VALUE name = Qnil;
10380 
10381   enc = rb_funcall(enc, ID_to_s, 0, 0);
10382   name = rb_hash_lookup(table, enc);
10383 
10384   if (!NIL_P(name)) {
10385     /* find */
10386     return name;
10387   }
10388 
10389   /* update check */
10390   if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp),
10391                                                error_mode)) {
10392     /* add new relations to the table   */
10393     /* RETRY: registered Ruby encoding? */
10394     name = rb_hash_lookup(table, enc);
10395     if (!NIL_P(name)) {
10396       /* find */
10397       return name;
10398     }
10399   }
10400 
10401   if (RTEST(error_mode)) {
10402     rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10403   }
10404   return Qnil;
10405 }
10406 static VALUE
10407 encoding_table_get_obj_core(table, enc, error_mode)
10408      VALUE table;
10409      VALUE enc;
10410      VALUE error_mode;
10411 {
10412   return encoding_table_get_name_core(table, enc, error_mode);
10413 }
10414 
10415 #else /* Tcl/Tk 7.x or 8.0 */
10416 static VALUE
10417 encoding_table_get_name_core(table, enc, error_mode)
10418      VALUE table;
10419      VALUE enc;
10420      VALUE error_mode;
10421 {
10422   return Qnil;
10423 }
10424 static VALUE
10425 encoding_table_get_obj_core(table, enc, error_mode)
10426      VALUE table;
10427      VALUE enc;
10428      VALUE error_mode;
10429 {
10430   return Qnil;
10431 }
10432 #endif /* end of dependency for the version of Tcl/Tk */
10433 #endif
10434 
10435 static VALUE
10436 encoding_table_get_name(table, enc)
10437      VALUE table;
10438      VALUE enc;
10439 {
10440   return encoding_table_get_name_core(table, enc, Qtrue);
10441 }
10442 static VALUE
10443 encoding_table_get_obj(table, enc)
10444      VALUE table;
10445      VALUE enc;
10446 {
10447   return encoding_table_get_obj_core(table, enc, Qtrue);
10448 }
10449 
10450 #ifdef HAVE_RUBY_ENCODING_H
10451 static VALUE
10452 create_encoding_table_core(arg, interp)
10453      VALUE arg;
10454      VALUE interp;
10455 {
10456   struct tcltkip *ptr = get_ip(interp);
10457   volatile VALUE table = rb_hash_new();
10458   volatile VALUE encname = Qnil;
10459   volatile VALUE encobj = Qnil;
10460   int i, idx, objc;
10461   Tcl_Obj **objv;
10462   Tcl_Obj *enc_list;
10463 
10464 #ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE
10465   rb_set_safe_level_force(0);
10466 #else
10467   rb_set_safe_level(0);
10468 #endif
10469 
10470   /* set 'binary' encoding */
10471   encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY));
10472   rb_hash_aset(table, ENCODING_NAME_BINARY, encobj);
10473   rb_hash_aset(table, encobj, ENCODING_NAME_BINARY);
10474 
10475 
10476   /* Tcl stub check */
10477   tcl_stubs_check();
10478 
10479   /* get Tcl's encoding list */
10480   Tcl_GetEncodingNames(ptr->ip);
10481   enc_list = Tcl_GetObjResult(ptr->ip);
10482   Tcl_IncrRefCount(enc_list);
10483 
10484   if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10485     Tcl_DecrRefCount(enc_list);
10486     rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10487   }
10488 
10489   /* get encoding name and set it to table */
10490   for(i = 0; i < objc; i++) {
10491     int name2obj, obj2name;
10492 
10493     name2obj = 1; obj2name = 1;
10494     encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10495     idx = rb_enc_find_index(StringValueCStr(encname));
10496     if (idx < 0) {
10497       /* fail to find ruby encoding -> check known encoding */
10498       if (strcmp(RSTRING_PTR(encname), "identity") == 0) {
10499         name2obj = 1; obj2name = 0;
10500         idx = ENCODING_INDEX_BINARY;
10501 
10502       } else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) {
10503         name2obj = 1; obj2name = 0;
10504         idx = rb_enc_find_index("Shift_JIS");
10505 
10506       } else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) {
10507         name2obj = 1; obj2name = 0;
10508         idx = ENCODING_INDEX_UTF8;
10509 
10510       } else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) {
10511         name2obj = 1; obj2name = 0;
10512         idx = rb_enc_find_index("ASCII-8BIT");
10513 
10514       } else {
10515         /* regist dummy encoding */
10516         name2obj = 1; obj2name = 1;
10517       }
10518     }
10519 
10520     if (idx < 0) {
10521       /* unknown encoding -> create dummy */
10522       encobj = create_dummy_encoding_for_tk(interp, encname);
10523     } else {
10524       encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10525     }
10526 
10527     if (name2obj) {
10528       DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname));
10529       rb_hash_aset(table, encname, encobj);
10530     }
10531     if (obj2name) {
10532       DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname));
10533       rb_hash_aset(table, encobj, encname);
10534     }
10535   }
10536 
10537   Tcl_DecrRefCount(enc_list);
10538 
10539   rb_ivar_set(table, ID_at_interp, interp);
10540   rb_ivar_set(interp, ID_encoding_table, table);
10541 
10542   return table;
10543 }
10544 
10545 #else /* ! HAVE_RUBY_ENCODING_H */
10546 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10547 static VALUE
10548 create_encoding_table_core(arg, interp)
10549      VALUE arg;
10550      VALUE interp;
10551 {
10552   struct tcltkip *ptr = get_ip(interp);
10553   volatile VALUE table = rb_hash_new();
10554   volatile VALUE encname = Qnil;
10555   int i, objc;
10556   Tcl_Obj **objv;
10557   Tcl_Obj *enc_list;
10558 
10559   rb_secure(4);
10560 
10561   /* set 'binary' encoding */
10562   rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY);
10563 
10564   /* get Tcl's encoding list */
10565   Tcl_GetEncodingNames(ptr->ip);
10566   enc_list = Tcl_GetObjResult(ptr->ip);
10567   Tcl_IncrRefCount(enc_list);
10568 
10569   if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10570     Tcl_DecrRefCount(enc_list);
10571     rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10572   }
10573 
10574   /* get encoding name and set it to table */
10575   for(i = 0; i < objc; i++) {
10576     encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10577     rb_hash_aset(table, encname, encname);
10578   }
10579 
10580   Tcl_DecrRefCount(enc_list);
10581 
10582   rb_ivar_set(table, ID_at_interp, interp);
10583   rb_ivar_set(interp, ID_encoding_table, table);
10584 
10585   return table;
10586 }
10587 
10588 #else /* Tcl/Tk 7.x or 8.0 */
10589 static VALUE
10590 create_encoding_table_core(arg, interp)
10591      VALUE arg;
10592      VALUE interp;
10593 {
10594   volatile VALUE table = rb_hash_new();
10595   rb_secure(4);
10596   rb_ivar_set(interp, ID_encoding_table, table);
10597   return table;
10598 }
10599 #endif
10600 #endif
10601 
10602 static VALUE
10603 create_encoding_table(interp)
10604      VALUE interp;
10605 {
10606   return rb_funcall(rb_proc_new(create_encoding_table_core, interp),
10607                     ID_call, 0);
10608 }
10609 
10610 static VALUE
10611 ip_get_encoding_table(interp)
10612      VALUE interp;
10613 {
10614   volatile VALUE table = Qnil;
10615 
10616   table = rb_ivar_get(interp, ID_encoding_table);
10617 
10618   if (NIL_P(table)) {
10619     /* initialize encoding_table */
10620     table = create_encoding_table(interp);
10621     rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1);
10622     rb_define_singleton_method(table, "get_obj",  encoding_table_get_obj,  1);
10623   }
10624 
10625   return table;
10626 }
10627 
10628 
10629 /*###############################################*/
10630 
10631 /*
10632  *   The following is based on tkMenu.[ch]
10633  *   of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code.
10634  */
10635 #if TCL_MAJOR_VERSION >= 8
10636 
10637 #define MASTER_MENU             0
10638 #define TEAROFF_MENU            1
10639 #define MENUBAR                 2
10640 
10641 struct dummy_TkMenuEntry {
10642     int type;
10643     struct dummy_TkMenu *menuPtr;
10644     /* , and etc.   */
10645 };
10646 
10647 struct dummy_TkMenu {
10648     Tk_Window tkwin;
10649     Display *display;
10650     Tcl_Interp *interp;
10651     Tcl_Command widgetCmd;
10652     struct dummy_TkMenuEntry **entries;
10653     int numEntries;
10654     int active;
10655     int menuType;     /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */
10656     Tcl_Obj *menuTypePtr;
10657     /* , and etc.   */
10658 };
10659 
10660 struct dummy_TkMenuRef {
10661     struct dummy_TkMenu *menuPtr;
10662     char *dummy1;
10663     char *dummy2;
10664     char *dummy3;
10665 };
10666 
10667 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10668 EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*);
10669 #else /* based on Tk8.0 -- Tk8.5.0 */
10670 #define MENU_HASH_KEY "tkMenus"
10671 #endif
10672 
10673 #endif
10674 
10675 static VALUE
10676 ip_make_menu_embeddable_core(interp, argc, argv)
10677     VALUE interp;
10678     int   argc;
10679     VALUE *argv;
10680 {
10681 #if TCL_MAJOR_VERSION >= 8
10682     volatile VALUE menu_path;
10683     struct tcltkip *ptr = get_ip(interp);
10684     struct dummy_TkMenuRef *menuRefPtr = NULL;
10685     XEvent event;
10686     Tcl_HashTable *menuTablePtr;
10687     Tcl_HashEntry *hashEntryPtr;
10688 
10689     menu_path = argv[0];
10690     StringValue(menu_path);
10691 
10692 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10693     menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path));
10694 #else /* based on Tk8.0 -- Tk8.5b1 */
10695     if ((menuTablePtr
10696          = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL))
10697         != NULL) {
10698       if ((hashEntryPtr
10699            = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path)))
10700           != NULL) {
10701         menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr);
10702       }
10703     }
10704 #endif
10705 
10706     if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) {
10707         rb_raise(rb_eArgError, "not a menu widget, or invalid widget path");
10708     }
10709 
10710     if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) {
10711         rb_raise(rb_eRuntimeError,
10712                  "invalid menu widget (maybe already destroyed)");
10713     }
10714 
10715     if ((menuRefPtr->menuPtr)->menuType != MENUBAR) {
10716         rb_raise(rb_eRuntimeError,
10717                  "target menu widget must be a MENUBAR type");
10718     }
10719 
10720     (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU;
10721 #if 0  /* cause SEGV */
10722     {
10723        /* char *s = "tearoff"; */
10724        char *s = "normal";
10725        /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/
10726        (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s));
10727        /* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */
10728        /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */
10729        (menuRefPtr->menuPtr)->menuType = MASTER_MENU;
10730     }
10731 #endif
10732 
10733 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10734     TkEventuallyRecomputeMenu(menuRefPtr->menuPtr);
10735     TkEventuallyRedrawMenu(menuRefPtr->menuPtr,
10736                            (struct dummy_TkMenuEntry *)NULL);
10737 #else /* based on Tk8.0 -- Tk8.5b1 */
10738     memset((void *) &event, 0, sizeof(event));
10739     event.xany.type = ConfigureNotify;
10740     event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin));
10741     event.xany.send_event = 0; /* FALSE */
10742     event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin);
10743     event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin);
10744     event.xconfigure.window = event.xany.window;
10745     Tk_HandleEvent(&event);
10746 #endif
10747 
10748 #else /* TCL_MAJOR_VERSION <= 7 */
10749     rb_notimplement();
10750 #endif
10751 
10752     return interp;
10753 }
10754 
10755 static VALUE
10756 ip_make_menu_embeddable(interp, menu_path)
10757     VALUE interp;
10758     VALUE menu_path;
10759 {
10760     VALUE argv[1];
10761 
10762     argv[0] = menu_path;
10763     return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp);
10764 }
10765 
10766 
10767 /*###############################################*/
10768 
10769 /*---- initialization ----*/
10770 void
10771 Init_tcltklib()
10772 {
10773     int  ret;
10774 
10775     VALUE lib = rb_define_module("TclTkLib");
10776     VALUE ip = rb_define_class("TclTkIp", rb_cObject);
10777 
10778     VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
10779     VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
10780     VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE");
10781 
10782     /* --------------------------------------------------------------- */
10783 
10784     tcltkip_class = ip;
10785 
10786     /* --------------------------------------------------------------- */
10787 
10788 #ifdef HAVE_RUBY_ENCODING_H
10789     rb_global_variable(&cRubyEncoding);
10790     cRubyEncoding = rb_path2class("Encoding");
10791 
10792     ENCODING_INDEX_UTF8   = rb_enc_to_index(rb_utf8_encoding());
10793     ENCODING_INDEX_BINARY = rb_enc_find_index("binary");
10794 #endif
10795 
10796     rb_global_variable(&ENCODING_NAME_UTF8);
10797     rb_global_variable(&ENCODING_NAME_BINARY);
10798 
10799     ENCODING_NAME_UTF8   = rb_obj_freeze(rb_str_new2("utf-8"));
10800     ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary"));
10801 
10802     /* --------------------------------------------------------------- */
10803 
10804     rb_global_variable(&eTkCallbackReturn);
10805     rb_global_variable(&eTkCallbackBreak);
10806     rb_global_variable(&eTkCallbackContinue);
10807 
10808     rb_global_variable(&eventloop_thread);
10809     rb_global_variable(&eventloop_stack);
10810     rb_global_variable(&watchdog_thread);
10811 
10812     rb_global_variable(&rbtk_pending_exception);
10813 
10814    /* --------------------------------------------------------------- */
10815 
10816     rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info());
10817 
10818     rb_define_const(lib, "RELEASE_DATE",
10819                     rb_obj_freeze(rb_str_new2(tcltklib_release_date)));
10820 
10821     rb_define_const(lib, "FINALIZE_PROC_NAME",
10822                     rb_str_new2(finalize_hook_name));
10823 
10824    /* --------------------------------------------------------------- */
10825 
10826 #ifdef __WIN32__
10827 #  define TK_WINDOWING_SYSTEM "win32"
10828 #else
10829 #  ifdef MAC_TCL
10830 #    define TK_WINDOWING_SYSTEM "classic"
10831 #  else
10832 #    ifdef MAC_OSX_TK
10833 #      define TK_WINDOWING_SYSTEM "aqua"
10834 #    else
10835 #      define TK_WINDOWING_SYSTEM "x11"
10836 #    endif
10837 #  endif
10838 #endif
10839     rb_define_const(lib, "WINDOWING_SYSTEM",
10840                     rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM)));
10841 
10842    /* --------------------------------------------------------------- */
10843 
10844     rb_define_const(ev_flag, "NONE",      INT2FIX(0));
10845     rb_define_const(ev_flag, "WINDOW",    INT2FIX(TCL_WINDOW_EVENTS));
10846     rb_define_const(ev_flag, "FILE",      INT2FIX(TCL_FILE_EVENTS));
10847     rb_define_const(ev_flag, "TIMER",     INT2FIX(TCL_TIMER_EVENTS));
10848     rb_define_const(ev_flag, "IDLE",      INT2FIX(TCL_IDLE_EVENTS));
10849     rb_define_const(ev_flag, "ALL",       INT2FIX(TCL_ALL_EVENTS));
10850     rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
10851 
10852     /* --------------------------------------------------------------- */
10853 
10854     rb_define_const(var_flag, "NONE",           INT2FIX(0));
10855     rb_define_const(var_flag, "GLOBAL_ONLY",    INT2FIX(TCL_GLOBAL_ONLY));
10856 #ifdef TCL_NAMESPACE_ONLY
10857     rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY));
10858 #else /* probably Tcl7.6 */
10859     rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0));
10860 #endif
10861     rb_define_const(var_flag, "LEAVE_ERR_MSG",  INT2FIX(TCL_LEAVE_ERR_MSG));
10862     rb_define_const(var_flag, "APPEND_VALUE",   INT2FIX(TCL_APPEND_VALUE));
10863     rb_define_const(var_flag, "LIST_ELEMENT",   INT2FIX(TCL_LIST_ELEMENT));
10864 #ifdef TCL_PARSE_PART1
10865     rb_define_const(var_flag, "PARSE_VARNAME",  INT2FIX(TCL_PARSE_PART1));
10866 #else /* probably Tcl7.6 */
10867     rb_define_const(var_flag, "PARSE_VARNAME",  INT2FIX(0));
10868 #endif
10869 
10870     /* --------------------------------------------------------------- */
10871 
10872     rb_define_module_function(lib, "get_version", lib_getversion, -1);
10873     rb_define_module_function(lib, "get_release_type_name",
10874                               lib_get_reltype_name, -1);
10875 
10876     rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE));
10877     rb_define_const(release_type, "BETA",  INT2FIX(TCL_BETA_RELEASE));
10878     rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE));
10879 
10880     /* --------------------------------------------------------------- */
10881 
10882     eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError);
10883     eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
10884     eTkCallbackContinue = rb_define_class("TkCallbackContinue",
10885                                           rb_eStandardError);
10886 
10887     /* --------------------------------------------------------------- */
10888 
10889     eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
10890 
10891     eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError);
10892 
10893     eTkCallbackRetry  = rb_define_class("TkCallbackRetry", eTkLocalJumpError);
10894     eTkCallbackRedo   = rb_define_class("TkCallbackRedo",  eTkLocalJumpError);
10895     eTkCallbackThrow  = rb_define_class("TkCallbackThrow", eTkLocalJumpError);
10896 
10897     /* --------------------------------------------------------------- */
10898 
10899     ID_at_enc = rb_intern("@encoding");
10900     ID_at_interp = rb_intern("@interp");
10901     ID_encoding_name = rb_intern("encoding_name");
10902     ID_encoding_table = rb_intern("encoding_table");
10903 
10904     ID_stop_p = rb_intern("stop?");
10905     ID_alive_p = rb_intern("alive?");
10906     ID_kill = rb_intern("kill");
10907     ID_join = rb_intern("join");
10908     ID_value = rb_intern("value");
10909 
10910     ID_call = rb_intern("call");
10911     ID_backtrace = rb_intern("backtrace");
10912     ID_message = rb_intern("message");
10913 
10914     ID_at_reason = rb_intern("@reason");
10915     ID_return = rb_intern("return");
10916     ID_break = rb_intern("break");
10917     ID_next = rb_intern("next");
10918 
10919     ID_to_s = rb_intern("to_s");
10920     ID_inspect = rb_intern("inspect");
10921 
10922     /* --------------------------------------------------------------- */
10923 
10924     rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
10925     rb_define_module_function(lib, "mainloop_thread?",
10926                               lib_evloop_thread_p, 0);
10927     rb_define_module_function(lib, "mainloop_watchdog",
10928                               lib_mainloop_watchdog, -1);
10929     rb_define_module_function(lib, "do_thread_callback",
10930                               lib_thread_callback, -1);
10931     rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1);
10932     rb_define_module_function(lib, "mainloop_abort_on_exception",
10933                              lib_evloop_abort_on_exc, 0);
10934     rb_define_module_function(lib, "mainloop_abort_on_exception=",
10935                              lib_evloop_abort_on_exc_set, 1);
10936     rb_define_module_function(lib, "set_eventloop_window_mode",
10937                               set_eventloop_window_mode, 1);
10938     rb_define_module_function(lib, "get_eventloop_window_mode",
10939                               get_eventloop_window_mode, 0);
10940     rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1);
10941     rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0);
10942     rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1);
10943     rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0);
10944     rb_define_module_function(lib, "set_eventloop_weight",
10945                               set_eventloop_weight, 2);
10946     rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1);
10947     rb_define_module_function(lib, "get_eventloop_weight",
10948                               get_eventloop_weight, 0);
10949     rb_define_module_function(lib, "num_of_mainwindows",
10950                               lib_num_of_mainwindows, 0);
10951 
10952     /* --------------------------------------------------------------- */
10953 
10954     rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1);
10955     rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1);
10956     rb_define_module_function(lib, "_conv_listelement",
10957                               lib_conv_listelement, 1);
10958     rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1);
10959     rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1);
10960     rb_define_module_function(lib, "_subst_UTF_backslash",
10961                               lib_UTF_backslash, 1);
10962     rb_define_module_function(lib, "_subst_Tcl_backslash",
10963                               lib_Tcl_backslash, 1);
10964 
10965     rb_define_module_function(lib, "encoding_system",
10966                               lib_get_system_encoding, 0);
10967     rb_define_module_function(lib, "encoding_system=",
10968                               lib_set_system_encoding, 1);
10969     rb_define_module_function(lib, "encoding",
10970                               lib_get_system_encoding, 0);
10971     rb_define_module_function(lib, "encoding=",
10972                               lib_set_system_encoding, 1);
10973 
10974     /* --------------------------------------------------------------- */
10975 
10976     rb_define_alloc_func(ip, ip_alloc);
10977     rb_define_method(ip, "initialize", ip_init, -1);
10978     rb_define_method(ip, "create_slave", ip_create_slave, -1);
10979     rb_define_method(ip, "slave_of?", ip_is_slave_of_p, 1);
10980     rb_define_method(ip, "make_safe", ip_make_safe, 0);
10981     rb_define_method(ip, "safe?", ip_is_safe_p, 0);
10982     rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0);
10983     rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1);
10984     rb_define_method(ip, "delete", ip_delete, 0);
10985     rb_define_method(ip, "deleted?", ip_is_deleted_p, 0);
10986     rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0);
10987     rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0);
10988     rb_define_method(ip, "_eval", ip_eval, 1);
10989     rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1);
10990     rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -1);
10991     rb_define_method(ip, "_toUTF8", ip_toUTF8, -1);
10992     rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1);
10993     rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1);
10994     rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2);
10995     rb_define_method(ip, "_invoke", ip_invoke, -1);
10996     rb_define_method(ip, "_immediate_invoke", ip_invoke_immediate, -1);
10997     rb_define_method(ip, "_return_value", ip_retval, 0);
10998 
10999     rb_define_method(ip, "_create_console", ip_create_console, 0);
11000 
11001     /* --------------------------------------------------------------- */
11002 
11003     rb_define_method(ip, "create_dummy_encoding_for_tk",
11004                      create_dummy_encoding_for_tk, 1);
11005     rb_define_method(ip, "encoding_table", ip_get_encoding_table, 0);
11006 
11007     /* --------------------------------------------------------------- */
11008 
11009     rb_define_method(ip, "_get_variable", ip_get_variable, 2);
11010     rb_define_method(ip, "_get_variable2", ip_get_variable2, 3);
11011     rb_define_method(ip, "_set_variable", ip_set_variable, 3);
11012     rb_define_method(ip, "_set_variable2", ip_set_variable2, 4);
11013     rb_define_method(ip, "_unset_variable", ip_unset_variable, 2);
11014     rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3);
11015     rb_define_method(ip, "_get_global_var", ip_get_global_var, 1);
11016     rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2);
11017     rb_define_method(ip, "_set_global_var", ip_set_global_var, 2);
11018     rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3);
11019     rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1);
11020     rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2);
11021 
11022     /* --------------------------------------------------------------- */
11023 
11024     rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1);
11025 
11026     /* --------------------------------------------------------------- */
11027 
11028     rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
11029     rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
11030     rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);
11031 
11032     /* --------------------------------------------------------------- */
11033 
11034     rb_define_method(ip, "mainloop", ip_mainloop, -1);
11035     rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1);
11036     rb_define_method(ip, "do_one_event", ip_do_one_event, -1);
11037     rb_define_method(ip, "mainloop_abort_on_exception",
11038                     ip_evloop_abort_on_exc, 0);
11039     rb_define_method(ip, "mainloop_abort_on_exception=",
11040                     ip_evloop_abort_on_exc_set, 1);
11041     rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1);
11042     rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0);
11043     rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1);
11044     rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0);
11045     rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2);
11046     rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0);
11047     rb_define_method(ip, "set_max_block_time", set_max_block_time, 1);
11048     rb_define_method(ip, "restart", ip_restart, 0);
11049 
11050     /* --------------------------------------------------------------- */
11051 
11052     eventloop_thread = Qnil;
11053     eventloop_interp = (Tcl_Interp*)NULL;
11054 
11055 #ifndef DEFAULT_EVENTLOOP_DEPTH
11056 #define DEFAULT_EVENTLOOP_DEPTH 7
11057 #endif
11058     eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH);
11059     RbTk_OBJ_UNTRUST(eventloop_stack);
11060 
11061     watchdog_thread  = Qnil;
11062 
11063     rbtk_pending_exception = Qnil;
11064 
11065     /* --------------------------------------------------------------- */
11066 
11067 #ifdef HAVE_NATIVETHREAD
11068     /* if ruby->nativethread-supprt and tcltklib->doen't,
11069        the following will cause link-error. */
11070     ruby_native_thread_p();
11071 #endif
11072 
11073     /* --------------------------------------------------------------- */
11074 
11075     rb_set_end_proc(lib_mark_at_exit, 0);
11076 
11077     /* --------------------------------------------------------------- */
11078 
11079     ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0);
11080     switch(ret) {
11081     case TCLTK_STUBS_OK:
11082         break;
11083     case NO_TCL_DLL:
11084         rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
11085     case NO_FindExecutable:
11086         rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
11087     default:
11088         rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret);
11089     }
11090 
11091     /* --------------------------------------------------------------- */
11092 
11093 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
11094     setup_rubytkkit();
11095 #endif
11096 
11097     /* --------------------------------------------------------------- */
11098 
11099     /* Tcl stub check */
11100     tcl_stubs_check();
11101 
11102     Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray);
11103     Tcl_ObjType_String    = Tcl_GetObjType(Tcl_ObjTypeName_String);
11104 
11105     /* --------------------------------------------------------------- */
11106 
11107     (void)call_original_exit;
11108 }
11109 
11110 /* eof */
11111