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