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