Ruby 1.9.2p136(2010-12-25revision30365)

- 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