Ruby: ext/tk/tcltklib.c Source File

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