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