diff options
Diffstat (limited to 'ext/tk/tcltklib.c')
-rw-r--r-- | ext/tk/tcltklib.c | 632 |
1 files changed, 453 insertions, 179 deletions
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c index 18e0fd76fb..7fa85daecc 100644 --- a/ext/tk/tcltklib.c +++ b/ext/tk/tcltklib.c @@ -4,7 +4,7 @@ * Oct. 24, 1997 Y. Matsumoto */ -#define TCLTKLIB_RELEASE_DATE "2008-03-29" +#define TCLTKLIB_RELEASE_DATE "2008-06-11" #include "ruby.h" @@ -171,7 +171,7 @@ static ID ID_inspect; static VALUE ip_invoke_real _((int, VALUE*, VALUE)); static VALUE ip_invoke _((int, VALUE*, VALUE)); - +static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition)); static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); /* Tcl's object type */ @@ -189,6 +189,10 @@ static Tcl_ObjType *Tcl_ObjType_String; #endif #endif +#ifndef HAVE_RB_HASH_LOOKUP +#define rb_hash_lookup rb_hash_aref +#endif + /* safe Tcl_Eval and Tcl_GlobalEval */ static int #ifdef RUBY_VM @@ -393,19 +397,24 @@ static VALUE eventloop_thread; Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */ #endif static VALUE eventloop_stack; -static int window_event_mode = ~(TCL_WINDOW_EVENTS | TCL_IDLE_EVENTS); +static int window_event_mode = ( ~ TCL_IDLE_EVENTS | TCL_WINDOW_EVENTS ); static VALUE watchdog_thread; Tcl_Interp *current_interp; /* thread control strategy */ -#define CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE 0 +/* multi-tk works with the following settings only ??? + : CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 + : USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 + : DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 +*/ +#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 -#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1 +#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE -static int have_rb_thread_waited_for_value = 0; +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE +static int have_rb_thread_waiting_for_value = 0; #endif /* @@ -422,9 +431,6 @@ static int have_rb_thread_waited_for_value = 0; #define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ #define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ #define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE -#define DEFAULT_HAS_WAIT_THREAD_TICK 50/*counts*/ -#endif #else /* ! RUBY_VM */ #define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ #define DEFAULT_NO_EVENT_TICK 10/*counts*/ @@ -432,9 +438,6 @@ static int have_rb_thread_waited_for_value = 0; #define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ #define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ #define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE -#define DEFAULT_HAS_WAIT_THREAD_TICK 50/*counts*/ -#endif #endif static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; @@ -443,9 +446,6 @@ static int no_event_wait = DEFAULT_NO_EVENT_WAIT; static int timer_tick = DEFAULT_TIMER_TICK; static int req_timer_tick = DEFAULT_TIMER_TICK; static int run_timer_flag = 0; -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE -static int has_wait_thread_tick = DEFAULT_HAS_WAIT_THREAD_TICK; -#endif static int event_loop_wait_event = 0; static int event_loop_abort_on_exc = 1; @@ -963,8 +963,10 @@ call_original_exit(ptr, state) int thr_crit_bup; Tcl_CmdInfo *info; #if TCL_MAJOR_VERSION >= 8 + Tcl_Obj *cmd_obj; Tcl_Obj *state_obj; #endif + DUMP1("original_exit is called"); if (!(ptr->has_orig_exit)) return; @@ -982,36 +984,55 @@ call_original_exit(ptr, state) if (info->isNativeObjectProc) { Tcl_Obj **argv; - /* argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); */ /* XXXXXXXXXX */ +#define USE_RUBY_ALLOC 0 +#if USE_RUBY_ALLOC + argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); +#else /* not USE_RUBY_ALLOC */ argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3); #if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ #endif - argv[0] = Tcl_NewStringObj("exit", 4); +#endif + cmd_obj = Tcl_NewStringObj("exit", 4); + Tcl_IncrRefCount(cmd_obj); + + argv[0] = cmd_obj; argv[1] = state_obj; argv[2] = (Tcl_Obj *)NULL; ptr->return_value = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); + Tcl_DecrRefCount(cmd_obj); + +#if USE_RUBY_ALLOC + free(argv); +#else /* not USE_RUBY_ALLOC */ #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree((char*)argv); #endif +#endif +#endif +#undef USE_RUBY_ALLOC } else { /* string interface */ char **argv; - /* argv = (char **)ALLOC_N(char *, 3); */ /* XXXXXXXXXX */ +#define USE_RUBY_ALLOC 0 +#if USE_RUBY_ALLOC + argv = (char **)ALLOC_N(char *, 3); /* XXXXXXXXXX */ +#else /* not USE_RUBY_ALLOC */ argv = (char **)ckalloc(sizeof(char *) * 3); #if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ #endif +#endif argv[0] = "exit"; /* argv[1] = Tcl_GetString(state_obj); */ argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); @@ -1020,15 +1041,21 @@ call_original_exit(ptr, state) ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, (CONST84 char **)argv); +#if USE_RUBY_ALLOC + free(argv); +#else /* not USE_RUBY_ALLOC */ #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree((char*)argv); #endif +#endif +#endif +#undef USE_RUBY_ALLOC } Tcl_DecrRefCount(state_obj); @@ -1037,11 +1064,15 @@ call_original_exit(ptr, state) { /* string interface */ char **argv; - /* argv = (char **)ALLOC_N(char *, 3); */ +#define USE_RUBY_ALLOC 0 +#if USE_RUBY_ALLOC + argv = (char **)ALLOC_N(char *, 3); +#else /* not USE_RUBY_ALLOC */ argv = (char **)ckalloc(sizeof(char *) * 3); #if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ #endif +#endif argv[0] = "exit"; argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10)); argv[2] = (char *)NULL; @@ -1049,17 +1080,24 @@ call_original_exit(ptr, state) ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv); +#if USE_RUBY_ALLOC + free(argv); +#else /* not USE_RUBY_ALLOC */ #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree(argv); #endif +#endif +#endif +#undef USE_RUBY_ALLOC } #endif + DUMP1("complete original_exit"); rb_thread_critical = thr_crit_bup; } @@ -1106,10 +1144,14 @@ static int toggle_eventloop_window_mode_for_idle() { if (window_event_mode & TCL_IDLE_EVENTS) { + /* idle -> event */ + window_event_mode |= TCL_WINDOW_EVENTS; window_event_mode &= ~TCL_IDLE_EVENTS; return 1; } else { + /* event -> idle */ window_event_mode |= TCL_IDLE_EVENTS; + window_event_mode &= ~TCL_WINDOW_EVENTS; return 0; } } @@ -1439,7 +1481,11 @@ static VALUE lib_num_of_mainwindows(self) VALUE self; { +#ifdef RUBY_VM /* Ruby 1.9+ !!! */ return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self); +#else + return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL); +#endif } @@ -1785,10 +1831,10 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) if (!st) { if (toggle_eventloop_window_mode_for_idle()) { /* idle-mode -> event-mode*/ - tick_counter = 0; + tick_counter = event_loop_max; } else { /* event-mode -> idle-mode */ - tick_counter = event_loop_max; + tick_counter = 0; } } #endif @@ -1798,6 +1844,14 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) st = RTEST(rb_protect(call_DoOneEvent, INT2FIX(event_flag), &status)); #endif + +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE + if (have_rb_thread_waiting_for_value) { + have_rb_thread_waiting_for_value = 0; + rb_thread_schedule(); + } +#endif + if (status) { switch (status) { case TAG_RAISE: @@ -1873,13 +1927,6 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) return 0; } -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE - if (have_rb_thread_waited_for_value) { - tick_counter += no_event_tick; - have_rb_thread_waited_for_value = 0; - } -#endif - if (st) { tick_counter++; } else { @@ -1946,7 +1993,8 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) } else { DUMP2("sleep eventloop %lx", current); DUMP2("eventloop thread is %lx", eventloop_thread); - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } if (!NIL_P(watchdog_thread) && eventloop_thread != current) { @@ -2122,7 +2170,11 @@ lib_eventloop_ensure(args) break; } +#ifdef RUBY_VM if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) { +#else + if (RTEST(rb_thread_alive_p(eventloop_thread))) { +#endif DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread); rb_thread_wakeup(eventloop_thread); @@ -2440,7 +2492,11 @@ lib_thread_callback(argc, argv, self) foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 0, q->done, (Tcl_Interp*)NULL)); +#ifdef RUBY_VM if (RTEST(rb_funcall(th, ID_alive_p, 0))) { +#else + if (RTEST(rb_thread_alive_p(th))) { +#endif rb_funcall(th, ID_kill, 0); ret = Qnil; } else { @@ -2581,10 +2637,12 @@ ip_set_exc_message(interp, exc) if (NIL_P(enc)) { encoding = (Tcl_Encoding)NULL; } else if (TYPE(enc) == T_STRING) { - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); } else { enc = rb_funcall(enc, ID_to_s, 0, 0); - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); } /* to avoid a garbled error message dialog */ @@ -2652,12 +2710,15 @@ tcl_protect_core(interp, proc, data) /* should not raise exception */ int status = 0; int thr_crit_bup = rb_thread_critical; + Tcl_ResetResult(interp); + rb_thread_critical = Qfalse; ret = rb_protect(proc, data, &status); rb_thread_critical = Qtrue; if (status) { char *buf; - VALUE old_gc, type, str; + VALUE old_gc; + volatile VALUE type, str; old_gc = rb_gc_disable(); @@ -3119,10 +3180,6 @@ ip_ruby_cmd(clientData, interp, argc, argv) #endif } - /* allocate */ - arg = ALLOC(struct cmd_body_arg); - /* arg = (struct cmd_body_arg *)ckalloc(sizeof(struct cmd_body_arg)); */ - /* get arguments from Tcl objects */ thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; @@ -3147,6 +3204,7 @@ ip_ruby_cmd(clientData, interp, argc, argv) str, "'", (char *)NULL); rbtk_pending_exception = rb_exc_new2(rb_eArgError, Tcl_GetStringResult(interp)); + if (old_gc == Qfalse) rb_gc_enable(); return TCL_ERROR; #endif } @@ -3187,6 +3245,10 @@ ip_ruby_cmd(clientData, interp, argc, argv) if (old_gc == Qfalse) rb_gc_enable(); rb_thread_critical = thr_crit_bup; + /* allocate */ + arg = ALLOC(struct cmd_body_arg); + /* arg = (struct cmd_body_arg *)ckalloc(sizeof(struct cmd_body_arg)); */ + arg->receiver = receiver; arg->method = method; arg->args = args; @@ -3386,6 +3448,8 @@ ip_rbUpdateCommand(clientData, interp, objc, objv) #endif #endif + Tcl_ResetResult(interp); + if (objc == 1) { flags = TCL_DONT_WAIT; @@ -3554,6 +3618,8 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) DUMP1("start Ruby's 'thread_update' body"); + Tcl_ResetResult(interp); + if (objc == 1) { flags = TCL_DONT_WAIT; @@ -3613,7 +3679,8 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) while(!param->done) { DUMP1("wait for complete idle proc"); - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } #if 0 /* use Tcl_EventuallyFree */ @@ -3621,10 +3688,11 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif DUMP1("finish Ruby's 'thread_update'"); return TCL_OK; @@ -3736,6 +3804,8 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) #endif #endif + Tcl_ResetResult(interp); + if (objc != 2) { #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "name"); @@ -3971,6 +4041,7 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) #endif Tcl_Preserve(interp); + Tcl_ResetResult(interp); if (objc != 3) { #ifdef Tcl_WrongNumArgs @@ -4327,7 +4398,7 @@ rb_threadVwaitProc(clientData, interp, name1, name2, flags) } else { param->done = 1; } - rb_thread_wakeup(param->thread); + if (param->done != 0) rb_thread_wakeup(param->thread); return (char *)NULL; } @@ -4349,7 +4420,7 @@ rb_threadWaitVisibilityProc(clientData, eventPtr) if (eventPtr->type == DestroyNotify) { param->done = TKWAIT_MODE_DESTROY; } - rb_thread_wakeup(param->thread); + if (param->done != 0) rb_thread_wakeup(param->thread); } static void rb_threadWaitWindowProc _((ClientData, XEvent *)); @@ -4363,7 +4434,7 @@ rb_threadWaitWindowProc(clientData, eventPtr) if (eventPtr->type == DestroyNotify) { param->done = TKWAIT_MODE_DESTROY; } - rb_thread_wakeup(param->thread); + if (param->done != 0) rb_thread_wakeup(param->thread); } #if TCL_MAJOR_VERSION >= 8 @@ -4406,6 +4477,7 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) } Tcl_Preserve(interp); + Tcl_ResetResult(interp); if (objc != 2) { #ifdef Tcl_WrongNumArgs @@ -4442,7 +4514,7 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ param = (struct th_vwait_param *)ckalloc(sizeof(struct th_vwait_param)); -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)param); #endif param->thread = current_thread; @@ -4465,12 +4537,13 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[1]); @@ -4479,9 +4552,9 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) return TCL_ERROR; } - /* if (!param->done) { */ while(!param->done) { - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } thr_crit_bup = rb_thread_critical; @@ -4496,12 +4569,13 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif rb_thread_critical = thr_crit_bup; @@ -4560,6 +4634,8 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) Tcl_Preserve(interp); Tcl_Preserve(tkwin); + Tcl_ResetResult(interp); + if (objc != 3) { #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); @@ -4644,7 +4720,7 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ param = (struct th_vwait_param *)ckalloc(sizeof(struct th_vwait_param)); -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)param); #endif param->thread = current_thread; @@ -4673,12 +4749,13 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4689,9 +4766,9 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) return TCL_ERROR; } - /* if (!param->done) { */ while(!param->done) { - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } thr_crit_bup = rb_thread_critical; @@ -4745,12 +4822,13 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4767,15 +4845,10 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) rb_thread_critical = thr_crit_bup; - /* if (!param->done) { */ - /* - while(!param->done) { - rb_thread_stop(); - } - */ while(param->done != TKWAIT_MODE_VISIBILITY) { if (param->done == TKWAIT_MODE_DESTROY) break; - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } thr_crit_bup = rb_thread_critical; @@ -4802,12 +4875,13 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4866,12 +4940,13 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif Tcl_Release(tkwin); Tcl_Release(interp); @@ -4885,14 +4960,9 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) rb_thread_critical = thr_crit_bup; - /* if (!param->done) { */ - /* - while(!param->done) { - rb_thread_stop(); - } - */ while(param->done != TKWAIT_MODE_DESTROY) { - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } Tcl_Release(window); @@ -4913,12 +4983,13 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 0 /* use Tcl_Preserve/Release */ +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)param); -#endif +#else /* Tcl_Free((char *)param); */ ckfree((char *)param); #endif +#endif /* * Clear out the interpreter's result, since it may have been set @@ -4943,7 +5014,7 @@ ip_thread_vwait(self, var) argv[0] = cmd_str; argv[1] = var; - return ip_invoke_real(2, argv, self); + return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL); } static VALUE @@ -4959,7 +5030,7 @@ ip_thread_tkwait(self, mode, target) argv[1] = mode; argv[2] = target; - return ip_invoke_real(3, argv, self); + return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL); } @@ -5149,14 +5220,18 @@ ip_finalize(ip) Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); #endif + /* + rb_thread_critical = thr_crit_bup; + return; + */ } /* delete root widget */ -#if 0 +#if 1 DUMP1("check `destroy'"); if (Tcl_GetCommandInfo(ip, "destroy", &info)) { - DUMP1("call `destroy'"); - Tcl_GlobalEval(ip, "destroy ."); + DUMP1("call `destroy .'"); + Tcl_GlobalEval(ip, "catch {destroy .}"); } #endif #if 1 @@ -5174,10 +5249,14 @@ ip_finalize(ip) * Although it is the problem, it is possibly avoidable by * rescuing exceptions and the finalize hook of the interp. */ + Tk_Window win = Tk_MainWindow(ip); + DUMP1("call Tk_DestroyWindow"); ruby_debug = Qfalse; ruby_verbose = Qnil; - Tk_DestroyWindow(Tk_MainWindow(ip)); + if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) { + Tk_DestroyWindow(win); + } ruby_debug = rb_debug_bup; ruby_verbose = rb_verbose_bup; } @@ -5200,7 +5279,7 @@ ip_finalize(ip) DUMP1("cancel after callbacks"); ruby_debug = Qfalse; ruby_verbose = Qnil; - Tcl_GlobalEval(ip, "foreach id [after info] {after cancel $id}"); + Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}"); ruby_debug = rb_debug_bup; ruby_verbose = rb_verbose_bup; } @@ -5242,8 +5321,8 @@ ip_free(ptr) if (ptr->ip == (Tcl_Interp*)NULL) { DUMP1("ip_free is called for deleted IP"); - /* free(ptr); */ - ckfree((char*)ptr); + free(ptr); + /* ckfree((char*)ptr); */ rb_thread_critical = thr_crit_bup; return; } @@ -5396,10 +5475,11 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* Tcl_Free((char*)argv); */ ckfree((char*)argv); #endif +#endif } DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); @@ -6273,12 +6353,12 @@ call_queue_handler(evPtr, flags) struct call_queue *q = (struct call_queue *)evPtr; volatile VALUE ret; volatile VALUE q_dat; + volatile VALUE thread = q->thread; struct tcltkip *ptr; DUMP2("do_call_queue_handler : evPtr = %p", evPtr); DUMP2("call_queue_handler thread : %lx", rb_thread_current()); - DUMP2("added by thread : %lx", q->thread); - + DUMP2("added by thread : %lx", thread); if (*(q->done)) { DUMP1("processed by another event-loop"); @@ -6287,6 +6367,17 @@ call_queue_handler(evPtr, flags) DUMP1("process it on current event-loop"); } +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#endif + DUMP1("caller is not yet ready to receive the result -> pending"); + return 0; + } + /* process it */ *(q->done) = 1; @@ -6307,14 +6398,16 @@ call_queue_handler(evPtr, flags) ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat), ID_call, 0); rb_gc_force_recycle(q_dat); + q_dat = (VALUE)NULL; } else { - DUMP2("call function (for caller thread:%lx)", q->thread); + DUMP2("call function (for caller thread:%lx)", thread); DUMP2("call function (current thread:%lx)", rb_thread_current()); ret = (q->func)(q->interp, q->argc, q->argv); } /* set result */ RARRAY_PTR(q->result)[0] = ret; + ret = (VALUE)NULL; /* decr internal handler mark */ rbtk_internal_eventloop_handler--; @@ -6322,22 +6415,32 @@ call_queue_handler(evPtr, flags) /* complete */ *(q->done) = -1; + /* unlink ruby objects */ + q->argv = (VALUE*)NULL; + q->interp = (VALUE)NULL; + q->result = (VALUE)NULL; + q->thread = (VALUE)NULL; + /* back to caller */ - if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { - DUMP2("back to caller (caller thread:%lx)", q->thread); +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread))) { +#endif + DUMP2("back to caller (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE - have_rb_thread_waited_for_value = 1; - rb_thread_wakeup(q->thread); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE + have_rb_thread_waiting_for_value = 1; + rb_thread_wakeup(thread); #else - rb_thread_run(q->thread); + rb_thread_run(thread); #endif DUMP1("finish back to caller"); #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE rb_thread_schedule(); #endif } else { - DUMP2("caller is dead (caller thread:%lx)", q->thread); + DUMP2("caller is dead (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); } @@ -6425,7 +6528,7 @@ tk_funcall(func, argc, argv, obj) /* allocate memory (freed by Tcl_ServiceEvent) */ /* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */ callq = (struct call_queue *)ckalloc(sizeof(struct call_queue)); -#if 1 /* use Tcl_Preserve/Release */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve(callq); #endif @@ -6447,17 +6550,24 @@ tk_funcall(func, argc, argv, obj) DUMP1("add handler"); #ifdef RUBY_VM if (ptr && ptr->tk_thread_id) { - Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(callq->ev), TCL_QUEUE_HEAD); + /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, + &(callq->ev), TCL_QUEUE_HEAD); */ + Tcl_ThreadQueueEvent(ptr->tk_thread_id, + (Tcl_Event*)callq, TCL_QUEUE_HEAD); Tcl_ThreadAlert(ptr->tk_thread_id); } else if (tk_eventloop_thread_id) { + /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, + &(callq->ev), TCL_QUEUE_HEAD); */ Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - &(callq->ev), TCL_QUEUE_HEAD); + (Tcl_Event*)callq, TCL_QUEUE_HEAD); Tcl_ThreadAlert(tk_eventloop_thread_id); } else { - Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); + /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ + Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); } #else - Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); + /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ + Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); #endif rb_thread_critical = thr_crit_bup; @@ -6466,7 +6576,8 @@ tk_funcall(func, argc, argv, obj) DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { DUMP2("*** wait for handler (current thread:%lx)", current); - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); @@ -6478,28 +6589,35 @@ tk_funcall(func, argc, argv, obj) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#endif +#else /* free(alloc_done); */ ckfree((char*)alloc_done); #endif +#endif /* if (argv) free(argv); */ if (argv) { /* if argv != NULL, alloc as 'temp' */ + int i; + for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; } + #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else ckfree((char*)argv); #endif +#endif } -#if 1 /* use Tcl_Preserve/Release */ +#if 0 /* callq is freed by Tcl_ServiceEvent */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Release(callq); #else ckfree((char*)callq); #endif +#endif /* exception? */ if (rb_obj_is_kind_of(ret, rb_eException)) { @@ -6620,11 +6738,26 @@ ip_eval_real(self, cmd_str, cmd_len) return rbtk_pending_exception; } - if (ptr->return_value == TCL_ERROR) { + /* if (ptr->return_value == TCL_ERROR) { */ + if (ptr->return_value != TCL_OK) { if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { volatile VALUE exc; - exc = create_ip_exc(self, rb_eRuntimeError, - "%s", Tcl_GetStringResult(ptr->ip)); + + switch (ptr->return_value) { + case TCL_RETURN: + exc = create_ip_exc(self, eTkCallbackReturn, + "ip_eval_real receives TCL_RETURN"); + case TCL_BREAK: + exc = create_ip_exc(self, eTkCallbackBreak, + "ip_eval_real receives TCL_BREAK"); + case TCL_CONTINUE: + exc = create_ip_exc(self, eTkCallbackContinue, + "ip_eval_real receives TCL_CONTINUE"); + default: + exc = create_ip_exc(self, rb_eRuntimeError, "%s", + Tcl_GetStringResult(ptr->ip)); + } + rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; return exc; @@ -6666,10 +6799,23 @@ ip_eval_real(self, cmd_str, cmd_len) return rbtk_pending_exception; } - if (ptr->return_value == TCL_ERROR) { + /* if (ptr->return_value == TCL_ERROR) { */ + if (ptr->return_value != TCL_OK) { volatile VALUE exc; - exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); + switch (ptr->return_value) { + case TCL_RETURN: + exc = create_ip_exc(self, eTkCallbackReturn, + "ip_eval_real receives TCL_RETURN"); + case TCL_BREAK: + exc = create_ip_exc(self, eTkCallbackBreak, + "ip_eval_real receives TCL_BREAK"); + case TCL_CONTINUE: + exc = create_ip_exc(self, eTkCallbackContinue, + "ip_eval_real receives TCL_CONTINUE"); + default: + exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); + } rbtk_release_ip(ptr); return exc; @@ -6705,11 +6851,12 @@ eval_queue_handler(evPtr, flags) struct eval_queue *q = (struct eval_queue *)evPtr; volatile VALUE ret; volatile VALUE q_dat; + volatile VALUE thread = q->thread; struct tcltkip *ptr; DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); DUMP2("eval_queue_thread : %lx", rb_thread_current()); - DUMP2("added by thread : %lx", q->thread); + DUMP2("added by thread : %lx", thread); if (*(q->done)) { DUMP1("processed by another event-loop"); @@ -6718,6 +6865,17 @@ eval_queue_handler(evPtr, flags) DUMP1("process it on current event-loop"); } +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#endif + DUMP1("caller is not yet ready to receive the result -> pending"); + return 0; + } + /* process it */ *(q->done) = 1; @@ -6751,12 +6909,14 @@ eval_queue_handler(evPtr, flags) ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), ID_call, 0); rb_gc_force_recycle(q_dat); + q_dat = (VALUE)NULL; } else { ret = ip_eval_real(q->interp, q->str, q->len); } /* set result */ RARRAY_PTR(q->result)[0] = ret; + ret = (VALUE)NULL; /* decr internal handler mark */ rbtk_internal_eventloop_handler--; @@ -6764,22 +6924,31 @@ eval_queue_handler(evPtr, flags) /* complete */ *(q->done) = -1; + /* unlink ruby objects */ + q->interp = (VALUE)NULL; + q->result = (VALUE)NULL; + q->thread = (VALUE)NULL; + /* back to caller */ - if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { - DUMP2("back to caller (caller thread:%lx)", q->thread); +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread))) { +#endif + DUMP2("back to caller (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE - have_rb_thread_waited_for_value = 1; - rb_thread_wakeup(q->thread); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE + have_rb_thread_waiting_for_value = 1; + rb_thread_wakeup(thread); #else - rb_thread_run(q->thread); + rb_thread_run(thread); #endif DUMP1("finish back to caller"); #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE rb_thread_schedule(); #endif } else { - DUMP2("caller is dead (caller thread:%lx)", q->thread); + DUMP2("caller is dead (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); } @@ -6838,7 +7007,7 @@ ip_eval(self, str) thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; - /* allocate memory (protected from Tcl_ServiceEvent) */ + /* allocate memory (keep result) */ /* alloc_done = (int*)ALLOC(int); */ alloc_done = (int*)ckalloc(sizeof(int)); #if 0 /* use Tcl_Preserve/Release */ @@ -6857,7 +7026,7 @@ ip_eval(self, str) /* allocate memory (freed by Tcl_ServiceEvent) */ /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */ evq = (struct eval_queue *)ckalloc(sizeof(struct eval_queue)); -#if 1 /* use Tcl_Preserve/Release */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve(evq); #endif @@ -6880,13 +7049,21 @@ ip_eval(self, str) DUMP1("add handler"); #ifdef RUBY_VM if (ptr->tk_thread_id) { - Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); + /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */ + Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position); Tcl_ThreadAlert(ptr->tk_thread_id); + } else if (tk_eventloop_thread_id) { + Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position); + /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, + &(evq->ev), position); */ + Tcl_ThreadAlert(tk_eventloop_thread_id); } else { - Tcl_QueueEvent(&(evq->ev), position); + /* Tcl_QueueEvent(&(evq->ev), position); */ + Tcl_QueueEvent((Tcl_Event*)evq, position); } #else - Tcl_QueueEvent(&(evq->ev), position); + /* Tcl_QueueEvent(&(evq->ev), position); */ + Tcl_QueueEvent((Tcl_Event*)evq, position); #endif rb_thread_critical = thr_crit_bup; @@ -6895,7 +7072,8 @@ ip_eval(self, str) DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { DUMP2("*** wait for handler (current thread:%lx)", current); - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); @@ -6908,24 +7086,28 @@ ip_eval(self, str) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#endif +#else /* free(alloc_done); */ ckfree((char*)alloc_done); #endif +#endif #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)eval_str); /* XXXXXXXX */ -#endif +#else /* free(eval_str); */ ckfree(eval_str); #endif -#if 1 /* use Tcl_Preserve/Release */ +#endif +#if 0 /* evq is freed by Tcl_ServiceEvent */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Release(evq); #else ckfree((char*)evq); #endif +#endif if (rb_obj_is_kind_of(ret, rb_eException)) { DUMP1("raise exception"); @@ -7100,11 +7282,18 @@ lib_toUTF8_core(ip_obj, src, encodename) if (NIL_P(enc)) { encoding = (Tcl_Encoding)NULL; } else { - StringValue(enc); - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); - if (encoding == (Tcl_Encoding)NULL) { + /* StringValue(enc); */ + enc = rb_funcall(enc, ID_to_s, 0, 0); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ + if (!RSTRING_LEN(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, + RSTRING_PTR(enc)); + if (encoding == (Tcl_Encoding)NULL) { rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); - } + } + } } } } else { @@ -7117,7 +7306,9 @@ lib_toUTF8_core(ip_obj, src, encodename) rb_thread_critical = thr_crit_bup; return str; } - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, + RSTRING_PTR(enc)); if (encoding == (Tcl_Encoding)NULL) { rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); } @@ -7135,7 +7326,8 @@ lib_toUTF8_core(ip_obj, src, encodename) rb_thread_critical = thr_crit_bup; return str; } - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); if (encoding == (Tcl_Encoding)NULL) { /* rb_warning("unknown encoding name '%s'", @@ -7170,9 +7362,11 @@ lib_toUTF8_core(ip_obj, src, encodename) rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); if (taint_flag) OBJ_TAINT(str); + /* if (encoding != (Tcl_Encoding)NULL) { Tcl_FreeEncoding(encoding); } + */ Tcl_DStringFree(&dstr); free(buf); @@ -7279,13 +7473,20 @@ lib_fromUTF8_core(ip_obj, src, encodename) if (NIL_P(enc)) { encoding = (Tcl_Encoding)NULL; } else { - StringValue(enc); - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); - if (encoding == (Tcl_Encoding)NULL) { + /* StringValue(enc); */ + enc = rb_funcall(enc, ID_to_s, 0, 0); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ + if (!RSTRING_LEN(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, + RSTRING_PTR(enc)); + if (encoding == (Tcl_Encoding)NULL) { rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); - } else { - encodename = rb_obj_dup(enc); - } + } else { + encodename = rb_obj_dup(enc); + } + } } } @@ -7293,14 +7494,17 @@ lib_fromUTF8_core(ip_obj, src, encodename) StringValue(encodename); if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { + Tcl_Obj *tclstr; char *s; int len; StringValue(str); - s = Tcl_GetByteArrayFromObj(Tcl_NewStringObj(RSTRING_PTR(str), - RSTRING_LEN(str)), - &len); + tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LEN(str)); + Tcl_IncrRefCount(tclstr); + s = Tcl_GetByteArrayFromObj(tclstr, &len); str = rb_tainted_str_new(s, len); + s = (char*)NULL; + Tcl_DecrRefCount(tclstr); #ifdef RUBY_VM rb_enc_associate_index(str, ENCODING_INDEX_BINARY); #endif @@ -7310,7 +7514,8 @@ lib_fromUTF8_core(ip_obj, src, encodename) return str; } - encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); + /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ + encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); if (encoding == (Tcl_Encoding)NULL) { /* rb_warning("unknown encoding name '%s'", @@ -7359,9 +7564,11 @@ lib_fromUTF8_core(ip_obj, src, encodename) if (taint_flag) OBJ_TAINT(str); + /* if (encoding != (Tcl_Encoding)NULL) { Tcl_FreeEncoding(encoding); } + */ Tcl_DStringFree(&dstr); free(buf); @@ -7459,19 +7666,21 @@ lib_UTF_backslash_core(self, str, all_bs) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)src_buf); /* XXXXXXXX */ -#endif +#else /* free(src_buf); */ ckfree(src_buf); #endif +#endif #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */ -#endif +#else /* free(dst_buf); */ ckfree(dst_buf); #endif +#endif rb_thread_critical = thr_crit_bup; #endif @@ -7596,10 +7805,11 @@ invoke_tcl_proc(arg) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree((char*)argv); #endif +#endif #else /* TCL_MAJOR_VERSION < 8 */ inf->ptr->return_value @@ -7829,10 +8039,11 @@ ip_invoke_core(interp, argc, argv) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree((char*)argv); #endif +#endif #else /* TCL_MAJOR_VERSION < 8 */ ptr->return_value = (*info.proc)(info.clientData, ptr->ip, @@ -7850,11 +8061,12 @@ ip_invoke_core(interp, argc, argv) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)objv); /* XXXXXXXX */ -#endif +#else /* free(objv); */ ckfree((char*)objv); #endif -#else +#endif +#else /* TCL_MAJOR_VERSION < 8 */ free(argv[0]); /* ckfree(argv[0]); */ #if 0 /* use Tcl_EventuallyFree */ @@ -7862,11 +8074,12 @@ ip_invoke_core(interp, argc, argv) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#endif +#else /* free(argv); */ ckfree((char*)argv); #endif #endif +#endif } /* exception on mainloop */ @@ -7876,11 +8089,24 @@ ip_invoke_core(interp, argc, argv) rb_thread_critical = thr_crit_bup; - if (ptr->return_value == TCL_ERROR) { + /* if (ptr->return_value == TCL_ERROR) { */ + if (ptr->return_value != TCL_OK) { if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { + switch (ptr->return_value) { + case TCL_RETURN: + return create_ip_exc(interp, eTkCallbackReturn, + "ip_invoke_core receives TCL_RETURN"); + case TCL_BREAK: + return create_ip_exc(interp, eTkCallbackBreak, + "ip_invoke_core receives TCL_BREAK"); + case TCL_CONTINUE: + return create_ip_exc(interp, eTkCallbackContinue, + "ip_invoke_core receives TCL_CONTINUE"); + default: + return create_ip_exc(interp, rb_eRuntimeError, "%s", + Tcl_GetStringResult(ptr->ip)); + } - return create_ip_exc(interp, rb_eRuntimeError, - "%s", Tcl_GetStringResult(ptr->ip)); } else { if (event_loop_abort_on_exc < 0) { rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); @@ -7963,8 +8189,10 @@ free_invoke_arguments(argc, av) for (i = 0; i < argc; ++i) { #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(av[i]); + av[i] = (Tcl_Obj*)NULL; #else /* TCL_MAJOR_VERSION < 8 */ free(av[i]); + av[i] = (char*)NULL; #endif } #if TCL_MAJOR_VERSION >= 8 @@ -7973,20 +8201,22 @@ free_invoke_arguments(argc, av) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)av); /* XXXXXXXX */ -#endif +#else ckfree((char*)av); #endif +#endif #else /* TCL_MAJOR_VERSION < 8 */ #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)av); /* XXXXXXXX */ -#endif +#else /* free(av); */ ckfree((char*)av); #endif #endif +#endif } static VALUE @@ -8049,11 +8279,12 @@ invoke_queue_handler(evPtr, flags) struct invoke_queue *q = (struct invoke_queue *)evPtr; volatile VALUE ret; volatile VALUE q_dat; + volatile VALUE thread = q->thread; struct tcltkip *ptr; DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); DUMP2("invoke queue_thread : %lx", rb_thread_current()); - DUMP2("added by thread : %lx", q->thread); + DUMP2("added by thread : %lx", thread); if (*(q->done)) { DUMP1("processed by another event-loop"); @@ -8062,6 +8293,17 @@ invoke_queue_handler(evPtr, flags) DUMP1("process it on current event-loop"); } +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread)) + && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { +#endif + DUMP1("caller is not yet ready to receive the result -> pending"); + return 0; + } + /* process it */ *(q->done) = 1; @@ -8082,14 +8324,16 @@ invoke_queue_handler(evPtr, flags) ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), ID_call, 0); rb_gc_force_recycle(q_dat); + q_dat = (VALUE)NULL; } else { - DUMP2("call invoke_real (for caller thread:%lx)", q->thread); + DUMP2("call invoke_real (for caller thread:%lx)", thread); DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); ret = ip_invoke_core(q->interp, q->argc, q->argv); } /* set result */ RARRAY_PTR(q->result)[0] = ret; + ret = (VALUE)NULL; /* decr internal handler mark */ rbtk_internal_eventloop_handler--; @@ -8097,22 +8341,31 @@ invoke_queue_handler(evPtr, flags) /* complete */ *(q->done) = -1; + /* unlink ruby objects */ + q->interp = (VALUE)NULL; + q->result = (VALUE)NULL; + q->thread = (VALUE)NULL; + /* back to caller */ - if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { - DUMP2("back to caller (caller thread:%lx)", q->thread); +#ifdef RUBY_VM + if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { +#else + if (RTEST(rb_thread_alive_p(thread))) { +#endif + DUMP2("back to caller (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE - have_rb_thread_waited_for_value = 1; - rb_thread_wakeup(q->thread); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE + have_rb_thread_waiting_for_value = 1; + rb_thread_wakeup(thread); #else - rb_thread_run(q->thread); + rb_thread_run(thread); #endif DUMP1("finish back to caller"); #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE rb_thread_schedule(); #endif } else { - DUMP2("caller is dead (caller thread:%lx)", q->thread); + DUMP2("caller is dead (caller thread:%lx)", thread); DUMP2(" (current thread:%lx)", rb_thread_current()); } @@ -8150,9 +8403,11 @@ ip_invoke_with_position(argc, argv, obj, position) #ifdef RUBY_VM ptr = get_ip(ip_obj); - DUMP2("status: ptr->tk_thread_id %d", ptr->tk_thread_id); + DUMP2("status: ptr->tk_thread_id %p", ptr->tk_thread_id); + DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); +#else + DUMP2("status: Tcl_GetCurrentThread %lx", Tcl_GetCurrentThread()); #endif - DUMP2("status: Tcl_GetCurrentThread %d", Tcl_GetCurrentThread()); DUMP2("status: eventloopt_thread %lx", eventloop_thread); if ( @@ -8193,7 +8448,7 @@ ip_invoke_with_position(argc, argv, obj, position) /* allocate memory (freed by Tcl_ServiceEvent) */ /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */ ivq = (struct invoke_queue *)ckalloc(sizeof(struct invoke_queue)); -#if 1 /* use Tcl_Preserve/Release */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */ #endif @@ -8214,13 +8469,22 @@ ip_invoke_with_position(argc, argv, obj, position) DUMP1("add handler"); #ifdef RUBY_VM if (ptr->tk_thread_id) { - Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); + /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */ + Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position); Tcl_ThreadAlert(ptr->tk_thread_id); + } else if (tk_eventloop_thread_id) { + /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, + &(ivq->ev), position); */ + Tcl_ThreadQueueEvent(tk_eventloop_thread_id, + (Tcl_Event*)ivq, position); + Tcl_ThreadAlert(tk_eventloop_thread_id); } else { - Tcl_QueueEvent(&(ivq->ev), position); + /* Tcl_QueueEvent(&(ivq->ev), position); */ + Tcl_QueueEvent((Tcl_Event*)ivq, position); } #else - Tcl_QueueEvent(&(ivq->ev), position); + /* Tcl_QueueEvent(&(ivq->ev), position); */ + Tcl_QueueEvent((Tcl_Event*)ivq, position); #endif rb_thread_critical = thr_crit_bup; @@ -8228,7 +8492,8 @@ ip_invoke_with_position(argc, argv, obj, position) /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { - rb_thread_stop(); + /* rb_thread_stop(); */ + rb_thread_sleep_forever(); } DUMP2("back from handler (current thread:%lx)", current); @@ -8239,20 +8504,23 @@ ip_invoke_with_position(argc, argv, obj, position) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#endif +#else /* free(alloc_done); */ ckfree((char*)alloc_done); #endif +#endif +#if 0 /* ivq is freed by Tcl_ServiceEvent */ #if 0 /* use Tcl_EventuallyFree */ Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */ #else -#if 1 /* use Tcl_Preserve/Release */ +#if 0 /* use Tcl_Preserve/Release */ Tcl_Release(ivq); #else ckfree((char*)ivq); #endif #endif +#endif /* free allocated memory */ free_invoke_arguments(argc, av); @@ -8938,10 +9206,11 @@ lib_merge_tklist(argc, argv, obj) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)flagPtr); -#endif +#else /* free(flagPtr); */ ckfree((char*)flagPtr); #endif +#endif /* create object */ str = rb_str_new(result, dst - result - 1); @@ -8951,10 +9220,11 @@ lib_merge_tklist(argc, argv, obj) #else #if 0 /* use Tcl_Preserve/Release */ Tcl_Release((ClientData)result); /* XXXXXXXXXXX */ -#endif +#else /* Tcl_Free(result); */ ckfree(result); #endif +#endif if (old_gc == Qfalse) rb_gc_enable(); rb_thread_critical = thr_crit_bup; @@ -9106,7 +9376,7 @@ create_dummy_encoding_for_tk_core(interp, name, error_mode) StringValue(name); #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) - if (Tcl_GetEncoding(ptr->ip, RSTRING_PTR(name)) == (Tcl_Encoding) NULL) { + if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) { if (RTEST(error_mode)) { rb_raise(rb_eArgError, "invalid Tk encoding name '%s'", RSTRING_PTR(name)); @@ -9704,6 +9974,7 @@ ip_make_menu_embeddable_core(interp, argc, argv) char *s = "normal"; /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/ (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s)); + /* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */ /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */ (menuRefPtr->menuPtr)->menuType = MASTER_MENU; } @@ -10048,6 +10319,9 @@ Init_tcltklib() /* --------------------------------------------------------------- */ + /* Tcl stub check */ + tcl_stubs_check(); + Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray); Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String); |