• Main Page
  • Modules
  • Data Structures
  • Files
  • File List
  • Globals

ext/tk/tcltklib.c

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

Generated on Wed Sep 8 2010 09:55:42 for Ruby by  doxygen 1.7.1