diff --git a/ChangeLog b/ChangeLog index 8b11a3c262..20db9233b5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,29 @@ +Wed Oct 15 00:20:15 2003 Hidetoshi NAGAI + + * ext/tcltklib/tcltklib.c: replace Tcl/Tk's vwait and tkwait to + switch on threads smoothly and avoid seg-fault. + + * ext/tcltklib/tcltklib.c: add TclTkIp._thread_vwait and + _thread_tkwait for waiting on a thread. (Because Tcl/Tk's vwait + and tkwait command wait on an eventloop.) + + * ext/tk/lib/multi-tk.rb: support TclTkIp._thread_vwait and + _thread_tkwait. + + * ext/tk/lib/tk.rb: now, TkVariable#wait has 2 arguments. + If 1st argument is true, waits on a thread. If false, waits on + an eventloop. If 2nd argument is true, checks existence of + rootwidgets. If false, doesn't. Default is wait(true, false). + + * ext/tk/lib/tk.rb: add TkVariable#tkwait(arg) which is equal to + TkVariable#wait(arg, true). wait_visibility and wait_destroy + have an argument for waiting on a thread or an eventloop. + + * ext/tk/lib/tk.rb: improve of accessing Tcl/Tk's special variables. + + * ext/tk/lib/tkafter.rb: support 'wait on a thread' and 'wait on + an eventloop'. + Wed Oct 15 00:10:24 2003 NAKAMURA, Hiroshi * lib/soap/baseData.rb: Introduce SOAPType as the common ancestor of diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc index 8a7143892c..90b32f00c7 100644 --- a/ext/tcltklib/MANUAL.euc +++ b/ext/tcltklib/MANUAL.euc @@ -1,5 +1,5 @@ (tof) - 2003/08/07 Hidetoshi NAGAI + 2003/10/12 Hidetoshi NAGAI 本ドキュメントには古い tcltk ライブラリ，tcltklib ライブラリの説明 が含まれていますが，その記述内容は古いものとなっています． @@ -348,6 +348,27 @@ require "tcltklib" _fromUTF8(str, encoding) : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す． + _thread_vwait(var_name) + _thread_tkwait(mode, target) + : スレッド対応の vwait あるいは tkwait 相当のメソッド． + : 通常の vwait あるいは tkwait コマンドと異なるのは，イベン + : トループとは異なるスレッドから呼び出した場合に vwait 等の + : スタックとは独立に条件の成立待ちがなされることである． + : 通常の vwait / tkwait では，vwait / tkwait (1) の待ちの途 + : 中でさらに vwait / tkwait (2) が呼ばれた場合，待ちの対象 + : となっている条件の成立順序がどうあれ，(2)->(1) の順で待ち + : を終了して戻ってくる． + : _thread_vwait / _thread_tkwait は，イベントループのスレッ + : ドで呼ばれた場合は通常の vwait / tkwait と同様に動作する + : が，イベントループ以外のスレッドで呼ばれた場合にはそのス + : レッドを停止させて待ちに入り，条件が成立した時にスレッド + : の実行を再開する．「vwait 等の待ちスタックとは独立」とい + : う意味は，この再開のタイミングが他のスレッドでの待ち状況 + : とは無関係ということである．つまり，イベントループ等の他 + : のスレッドで vwait 等で待ちの状態にあったとしてもその完了 + : を待つことなく，自らの待ち条件が成立次第，処理を継続する + : ことになる． + _return_value : 直前の Tcl/Tk 上での評価の実行結果としての戻り値を返す． diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c index fdc4b00305..6902f1e15c 100644 --- a/ext/tcltklib/tcltklib.c +++ b/ext/tcltklib/tcltklib.c @@ -39,6 +39,7 @@ static VALUE eTkCallbackBreak; static VALUE eTkCallbackContinue; static VALUE ip_invoke_real _((int, VALUE*, VALUE)); +static VALUE ip_invoke _((int, VALUE*, VALUE)); /* from tkAppInit.c */ @@ -81,7 +82,7 @@ Tcl_Interp *current_interp; #define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */ #define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ #define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ -#define NO_THREAD_INTERRUPT_TIME 200/*milliseconds ( 1 -- 999 ) */ +#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; static int no_event_tick = DEFAULT_NO_EVENT_TICK; @@ -94,6 +95,8 @@ static int event_loop_wait_event = 0; static int event_loop_abort_on_exc = 1; static int loop_counter = 0; +static int check_rootwidget_flag = 0; + #if TCL_MAJOR_VERSION >= 8 static int ip_ruby _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); #else @@ -357,13 +360,13 @@ lib_num_of_mainwindows(self) return INT2FIX(Tk_GetNumMainWindows()); } -VALUE -lib_mainloop_core(check_root_widget) - VALUE check_root_widget; +static int +lib_eventloop_core(check_root, check_var) + int check_root; + int *check_var; { VALUE current = eventloop_thread; - int check = RTEST(check_root_widget); - int tick_counter; + int found_event = 1; struct timeval t; t.tv_sec = (time_t)0; @@ -390,38 +393,58 @@ lib_mainloop_core(check_root_widget) (ClientData)0); } - Tcl_DoOneEvent(TCL_ALL_EVENTS); + if (check_var != (int *)NULL) { + if (*check_var || !found_event) { + return found_event; + } + } + + found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS); if (loop_counter++ > 30000) { loop_counter = 0; } if (run_timer_flag) { + /* DUMP1("timer interrupt"); run_timer_flag = 0; DUMP1("call rb_trap_exec()"); rb_trap_exec(); + */ DUMP1("check Root Widget"); - if (check && Tk_GetNumMainWindows() == 0) { - return Qnil; + if (check_root && Tk_GetNumMainWindows() == 0) { + run_timer_flag = 0; + rb_trap_exec(); + return 1; } } } else { + int tick_counter; + DUMP1("there are other threads"); event_loop_wait_event = 1; + found_event = 1; + timer_tick = req_timer_tick; tick_counter = 0; while(tick_counter < event_loop_max) { + if (check_var != (int *)NULL) { + if (*check_var || !found_event) { + return found_event; + } + } + if (Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)) { tick_counter++; } else { tick_counter += no_event_tick; DUMP1("check Root Widget"); - if (check && Tk_GetNumMainWindows() == 0) { - return Qnil; + if (check_root && Tk_GetNumMainWindows() == 0) { + return 1; } rb_thread_wait_for(t); @@ -432,35 +455,57 @@ lib_mainloop_core(check_root_widget) } if (watchdog_thread != 0 && eventloop_thread != current) { - return Qnil; + return 1; } if (run_timer_flag) { + /* DUMP1("timer interrupt"); run_timer_flag = 0; + */ break; /* switch to other thread */ } } DUMP1("check Root Widget"); - if (check && Tk_GetNumMainWindows() == 0) { - return Qnil; + if (check_root && Tk_GetNumMainWindows() == 0) { + return 1; } } - rb_thread_schedule(); + /* rb_thread_schedule(); */ + if (run_timer_flag) { + run_timer_flag = 0; + rb_trap_exec(); + } else { + DUMP1("thread scheduling"); + rb_thread_schedule(); + } } - return Qnil; + return 1; } VALUE -lib_mainloop_ensure(parent_evloop) +lib_eventloop_main(check_rootwidget) + VALUE check_rootwidget; +{ + check_rootwidget_flag = RTEST(check_rootwidget); + + if (lib_eventloop_core(check_rootwidget_flag, (int *)NULL)) { + return Qtrue; + } else { + return Qfalse; + } +} + +VALUE +lib_eventloop_ensure(parent_evloop) VALUE parent_evloop; { Tk_DeleteTimerHandler(timer_token); timer_token = (Tcl_TimerToken)NULL; - DUMP2("mainloop-ensure: current-thread : %lx\n", rb_thread_current()); - DUMP2("mainloop-ensure: eventloop-thread : %lx\n", eventloop_thread); + DUMP2("eventloop-ensure: current-thread : %lx\n", rb_thread_current()); + DUMP2("eventloop-ensure: eventloop-thread : %lx\n", eventloop_thread); if (eventloop_thread == rb_thread_current()) { DUMP2("eventloop-thread -> %lx\n", parent_evloop); eventloop_thread = parent_evloop; @@ -469,7 +514,7 @@ lib_mainloop_ensure(parent_evloop) } static VALUE -lib_mainloop_launcher(check_rootwidget) +lib_eventloop_launcher(check_rootwidget) VALUE check_rootwidget; { VALUE parent_evloop = eventloop_thread; @@ -481,8 +526,8 @@ lib_mainloop_launcher(check_rootwidget) parent_evloop, eventloop_thread); } - return rb_ensure(lib_mainloop_core, check_rootwidget, - lib_mainloop_ensure, parent_evloop); + return rb_ensure(lib_eventloop_main, check_rootwidget, + lib_eventloop_ensure, parent_evloop); } /* execute Tk_MainLoop */ @@ -502,7 +547,7 @@ lib_mainloop(argc, argv, self) check_rootwidget = Qfalse; } - return lib_mainloop_launcher(check_rootwidget); + return lib_eventloop_launcher(check_rootwidget); } static VALUE @@ -555,7 +600,7 @@ lib_watchdog_core(check_rootwidget) /* start new eventloop thread */ DUMP2("eventloop thread %lx is sleeping or dead", eventloop_thread); - evloop = rb_thread_create(lib_mainloop_launcher, + evloop = rb_thread_create(lib_eventloop_launcher, (void*)&check_rootwidget); DUMP2("create new eventloop thread %lx", evloop); loop_counter = -1; @@ -778,9 +823,11 @@ ip_ruby(clientData, interp, argc, argv) rb_eStandardError, rb_eScriptError, (VALUE)0); rb_trap_immediate = old_trapflg; - Tcl_ResetResult(interp); + /* status check */ if (failed) { VALUE eclass = CLASS_OF(failed); + DUMP1("(rb_eval_string result) failed"); + Tcl_ResetResult(interp); Tcl_AppendResult(interp, StringValuePtr(failed), (char*)NULL); if (eclass == eTkCallbackBreak) { return TCL_BREAK; @@ -794,17 +841,651 @@ ip_ruby(clientData, interp, argc, argv) /* result must be string or nil */ if (NIL_P(res)) { DUMP1("(rb_eval_string result) nil"); + Tcl_ResetResult(interp); return TCL_OK; } /* copy result to the tcl interpreter */ DUMP2("(rb_eval_string result) %s", StringValuePtr(res)); DUMP1("Tcl_AppendResult"); + Tcl_ResetResult(interp); Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL); return TCL_OK; } + +/**************************/ +/* based on tclEvent.c */ +/**************************/ +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_rbVwaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else +ip_rbVwaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int done, foundEvent; + char *nameString; + int dummy; + + DUMP1("Ruby's 'vwait' is called"); + if (objc != 2) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "name"); +#else +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[0]); */ + nameString = Tcl_GetStringFromObj(objv[0], &dummy); +#else + nameString = objv[0]; +#endif + Tcl_AppendResult(interp, "wrong # args: should be \"", + nameString, " name\"", (char *) NULL); +#endif + return TCL_ERROR; + } +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[1]); */ + nameString = Tcl_GetStringFromObj(objv[1], &dummy); +#else + nameString = objv[1]; +#endif + + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + }; + done = 0; + foundEvent = lib_eventloop_core(/* not check root-widget */0, &done); + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + +/**************************/ +/* based on tkCmd.c */ +/**************************/ +static char * +WaitVariableProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +static void +WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event (not used). */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == VisibilityNotify) { + *donePtr = 1; + } + if (eventPtr->type == DestroyNotify) { + *donePtr = 2; + } +} + +static void +WaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == DestroyNotify) { + *donePtr = 1; + } +} + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_rbTkWaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else +ip_rbTkWaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + Tk_Window tkwin = (Tk_Window) clientData; + int done, index; + static CONST char *optionStrings[] = { "variable", "visibility", "window", + (char *) NULL }; + enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; + char *nameString; + int dummy; + + DUMP1("Ruby's 'tkwait' is called"); + + if (objc != 3) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); +#else +#if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " variable|visibility|window name\"", + (char *) NULL); +#else + Tcl_AppendResult(interp, "wrong # args: should be \"", + objv[0], " variable|visibility|window name\"", + (char *) NULL); +#endif +#endif + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + if (Tcl_GetIndexFromObj(interp, objv[1], +# ifdef CONST84 /* Tcl8.4.x -- ?.?.? (current latest version is 8.4.4) */ + (CONST84 char **)optionStrings, +# else +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */ + (char **)optionStrings, +# else /* unknown (maybe TCL_VERSION >= 8.5) */ +# ifdef CONST + (CONST char **)optionStrings, +# else + optionStrings, +# endif +# endif +# endif + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } +#else + { + int c = objv[1][0]; + size_t length = strlen(objv[1]); + + if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) + && (length >= 2)) { + index = TKWAIT_VARIABLE; + } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) + && (length >= 2)) { + index = TKWAIT_VISIBILITY; + } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { + index = TKWAIT_WINDOW; + } else { + Tcl_AppendResult(interp, "bad option \"", objv[1], + "\": must be variable, visibility, or window", + (char *) NULL); + return TCL_ERROR; + } + } +#endif + +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[2]); */ + nameString = Tcl_GetStringFromObj(objv[2], &dummy); +#else + nameString = objv[2]; +#endif + + switch ((enum options) index) { + case TKWAIT_VARIABLE: { + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + lib_eventloop_core(check_rootwidget_flag, &done); + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + break; + } + + case TKWAIT_VISIBILITY: { + Tk_Window window; + + window = Tk_NameToWindow(interp, nameString, tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + done = 0; + lib_eventloop_core(check_rootwidget_flag, &done); + if (done != 1) { + /* + * Note that we do not delete the event handler because it + * was deleted automatically when the window was destroyed. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", nameString, + "\" was deleted before its visibility changed", + (char *) NULL); + return TCL_ERROR; + } + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + break; + } + + case TKWAIT_WINDOW: { + Tk_Window window; + + window = Tk_NameToWindow(interp, nameString, tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, StructureNotifyMask, + WaitWindowProc, (ClientData) &done); + done = 0; + lib_eventloop_core(check_rootwidget_flag, &done); + /* + * Note: there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed. + */ + break; + } + } + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +/****************************/ +/* vwait/tkwait with thread */ +/****************************/ +struct th_vwait_param { + VALUE thread; + int done; +}; + +static char * +rb_threadVwaitProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + param->done = 1; + rb_thread_run(param->thread); + + return (char *)NULL; +} + +static void +rb_threadWaitVisibilityProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event (not used). */ +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + if (eventPtr->type == VisibilityNotify) { + param->done = 1; + } + if (eventPtr->type == DestroyNotify) { + param->done = 2; + } +} + +static void +rb_threadWaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + if (eventPtr->type == DestroyNotify) { + param->done = 1; + } +} + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else +ip_rb_threadVwaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + struct th_vwait_param *param; + char *nameString; + int dummy; + + DUMP1("Ruby's 'thread_vwait' is called"); + + if (eventloop_thread == rb_thread_current()) { +#if TCL_MAJOR_VERSION >= 8 + DUMP1("call ip_rbVwaitObjCmd"); + return ip_rbVwaitObjCmd(clientData, interp, objc, objv); +#else + DUMP1("call ip_rbVwaitCommand"); + return ip_rbVwaitCommand(clientData, interp, objc, objv); +#endif + } + + if (objc != 2) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "name"); +#else +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[0]); */ + nameString = Tcl_GetStringFromObj(objv[0], &dummy); +#else + nameString = objv[0]; +#endif + Tcl_AppendResult(interp, "wrong # args: should be \"", + nameString, " name\"", (char *) NULL); +#endif + return TCL_ERROR; + } +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[1]); */ + nameString = Tcl_GetStringFromObj(objv[1], &dummy); +#else + nameString = objv[1]; +#endif + + param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); + param->thread = rb_thread_current(); + param->done = 0; + + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param) != TCL_OK) { + return TCL_ERROR; + }; + + if (!param->done) { + rb_thread_stop(); + } + + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + + Tcl_Free((char *)param); + + return TCL_OK; +} + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else +ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + struct th_vwait_param *param; + Tk_Window tkwin = (Tk_Window) clientData; + int index; + static CONST char *optionStrings[] = { "variable", "visibility", "window", + (char *) NULL }; + enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; + char *nameString; + int dummy; + + DUMP1("Ruby's 'thread_tkwait' is called"); + + if (eventloop_thread == rb_thread_current()) { +#if TCL_MAJOR_VERSION >= 8 + DUMP1("call ip_rbTkWaitObjCmd"); + return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); +#else + DUMP1("call rb_VwaitCommand"); + return ip_rbTkWaitCommand(clientData, interp, objc, objv); +#endif + } + + if (objc != 3) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); +#else +#if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " variable|visibility|window name\"", + (char *) NULL); +#else + Tcl_AppendResult(interp, "wrong # args: should be \"", + objv[0], " variable|visibility|window name\"", + (char *) NULL); +#endif +#endif + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + if (Tcl_GetIndexFromObj(interp, objv[1], +# ifdef CONST84 /* Tcl8.4.x -- ?.?.? (current latest version is 8.4.4) */ + (CONST84 char **)optionStrings, +# else +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */ + (char **)optionStrings, +# else /* unknown (maybe TCL_VERSION >= 8.5) */ +# ifdef CONST + (CONST char **)optionStrings, +# else + optionStrings, +# endif +# endif +# endif + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } +#else + { + int c = objv[1][0]; + size_t length = strlen(objv[1]); + + if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) + && (length >= 2)) { + index = TKWAIT_VARIABLE; + } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) + && (length >= 2)) { + index = TKWAIT_VISIBILITY; + } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { + index = TKWAIT_WINDOW; + } else { + Tcl_AppendResult(interp, "bad option \"", objv[1], + "\": must be variable, visibility, or window", + (char *) NULL); + return TCL_ERROR; + } + } +#endif + +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[2]); */ + nameString = Tcl_GetStringFromObj(objv[2], &dummy); +#else + nameString = objv[2]; +#endif + + param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); + param->thread = rb_thread_current(); + param->done = 0; + + switch ((enum options) index) { + case TKWAIT_VARIABLE: { + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param) != TCL_OK) { + return TCL_ERROR; + }; + + if (!param->done) { + rb_thread_stop(); + } + + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + break; + } + + case TKWAIT_VISIBILITY: { + Tk_Window window; + + window = Tk_NameToWindow(interp, nameString, tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + rb_threadWaitVisibilityProc, (ClientData) param); + if (!param->done) { + rb_thread_stop(); + } + if (param->done != 1) { + /* + * Note that we do not delete the event handler because it + * was deleted automatically when the window was destroyed. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", nameString, + "\" was deleted before its visibility changed", + (char *) NULL); + return TCL_ERROR; + } + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + rb_threadWaitVisibilityProc, (ClientData) param); + break; + } + + case TKWAIT_WINDOW: { + Tk_Window window; + + window = Tk_NameToWindow(interp, nameString, tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, StructureNotifyMask, + rb_threadWaitWindowProc, (ClientData) param); + if (!param->done) { + rb_thread_stop(); + } + /* + * Note: there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed. + */ + break; + } + } + + Tcl_Free((char *)param); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +static VALUE +ip_thread_vwait(self, var) + VALUE self; + VALUE var; +{ + VALUE argv[2]; + + argv[0] = rb_str_new2("thread_vwait"); + argv[1] = var; + return ip_invoke_real(2, argv, self); +} + +static VALUE +ip_thread_tkwait(self, mode, target) + VALUE self; + VALUE mode; + VALUE target; +{ + VALUE argv[3]; + + argv[0] = rb_str_new2("thread_tkwait"); + argv[1] = mode; + argv[2] = target; + return ip_invoke_real(3, argv, self); +} + + /* destroy interpreter */ static void ip_free(ptr) @@ -903,6 +1584,50 @@ ip_init(argc, argv, self) (Tcl_CmdDeleteProc *)NULL); #endif + /* replace 'vwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"vwait\")"); + Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#else + DUMP1("Tcl_CreateCommand(\"vwait\")"); + Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* replace 'tkwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); + Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#else + DUMP1("Tcl_CreateCommand(\"tkwait\")"); + Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* add 'thread_vwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#else + DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); + Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* add 'thread_tkwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#else + DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); + Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); +#endif + return self; } @@ -1137,20 +1862,23 @@ ip_invoke_real(argc, argv, obj) Tcl_Obj *resultPtr; #endif - /* get the data struct */ - ptr = get_ip(obj); - + DUMP2("invoke_real called by thread:%lx", rb_thread_current()); /* get the command name string */ v = argv[0]; cmd = StringValuePtr(v); + /* get the data struct */ + ptr = get_ip(obj); + /* ip is deleted? */ if (Tcl_InterpDeleted(ptr->ip)) { return rb_tainted_str_new2(""); } /* map from the command name to a C procedure */ + DUMP2("call Tcl_GetCommandInfo, %s", cmd); if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { + DUMP1("error Tcl_GetCommandInfo"); /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ if (event_loop_abort_on_exc > 0) { /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/ @@ -1166,6 +1894,7 @@ ip_invoke_real(argc, argv, obj) return rb_tainted_str_new2(""); } } + DUMP1("end Tcl_GetCommandInfo"); /* memory allocation for arguments of this command */ #if TCL_MAJOR_VERSION >= 8 @@ -1281,13 +2010,15 @@ invoke_queue_handler(evPtr, flags) { struct invoke_queue *q = (struct invoke_queue *)evPtr; - DUMP1("do_invoke_queue_handler"); + DUMP2("do_invoke_queue_handler : evPtr = %lx", evPtr); DUMP2("invoke queue_thread : %lx", rb_thread_current()); DUMP2("added by thread : %lx", q->thread); if (q->done) { - /* processed by another event-loop */ + DUMP1("processed by another event-loop"); return 0; + } else { + DUMP1("process it on current event-loop"); } /* process it */ @@ -1300,11 +2031,16 @@ invoke_queue_handler(evPtr, flags) Data_Wrap_Struct(rb_cData,0,0,q)), rb_intern("call"), 0); } else { + DUMP2("call invoke_real (for caller thread:%lx)", q->thread); + DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj); } /* back to caller */ + DUMP2("back to caller (caller thread:%lx)", q->thread); + DUMP2(" (current thread:%lx)", rb_thread_current()); rb_thread_run(q->thread); + DUMP1("finish back to caller"); /* end of handler : remove it */ return 1; @@ -1326,7 +2062,11 @@ ip_invoke(argc, argv, obj) rb_raise(rb_eArgError, "command name missing"); } if (eventloop_thread == 0 || current == eventloop_thread) { - DUMP2("invoke from current eventloop %lx", current); + if (eventloop_thread) { + DUMP2("invoke from current eventloop %lx", current); + } else { + DUMP2("invoke from thread:%lx but no eventloop", current); + } result = ip_invoke_real(argc, argv, obj); if (rb_obj_is_kind_of(result, rb_eException)) { rb_exc_raise(result); @@ -1341,7 +2081,7 @@ ip_invoke(argc, argv, obj) MEMCPY(alloc_argv, argv, VALUE, argc); alloc_result = ALLOC(VALUE); - /* allocate memory (freed by Tcl_ServiceEvent */ + /* allocate memory (freed by Tcl_ServiceEvent) */ tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); /* construct event data */ @@ -1356,10 +2096,13 @@ ip_invoke(argc, argv, obj) position = TCL_QUEUE_TAIL; /* add the handler to Tcl event queue */ - Tcl_QueueEvent(&tmp->ev, position); + DUMP1("add handler"); + Tcl_QueueEvent(&(tmp->ev), position); /* wait for the handler to be processed */ + DUMP2("wait for handler (current thread:%lx)", current); rb_thread_stop(); + DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ result = *alloc_result; @@ -1449,8 +2192,10 @@ Init_tcltklib() rb_define_method(ip, "delete", ip_delete, 0); rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); rb_define_method(ip, "_eval", ip_eval, 1); - rb_define_method(ip, "_toUTF8",ip_toUTF8,2); - rb_define_method(ip, "_fromUTF8",ip_fromUTF8,2); + rb_define_method(ip, "_toUTF8",ip_toUTF8, 2); + rb_define_method(ip, "_fromUTF8",ip_fromUTF8, 2); + rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1); + rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2); rb_define_method(ip, "_invoke", ip_invoke, -1); rb_define_method(ip, "_return_value", ip_retval, 0); diff --git a/ext/tk/lib/multi-tk.rb b/ext/tk/lib/multi-tk.rb index 750a2b79d9..288b5be443 100644 --- a/ext/tk/lib/multi-tk.rb +++ b/ext/tk/lib/multi-tk.rb @@ -306,7 +306,8 @@ class MultiTkIp # check 'display' if !new_keys.key?('display') begin - new_keys['display'] = @interp._eval('winfo screen .') + #new_keys['display'] = @interp._invoke('winfo screen .') + new_keys['display'] = @interp._invoke('winfo', 'screen', '.') rescue if ENV[DISPLAY] new_keys['display'] = ENV[DISPLAY] @@ -323,7 +324,8 @@ class MultiTkIp case new_keys['use'] when TkWindow new_keys['use'] = TkWinfo.id(new_keys['use']) - assoc_display = @interp._eval('winfo screen .') + #assoc_display = @interp._eval('winfo screen .') + assoc_display = @interp._invoke('winfo', 'screen', '.') when /^\..*/ new_keys['use'] = @interp._invoke('winfo', 'id', new_keys['use']) assoc_display = @interp._invoke('winfo', 'screen', new_keys['use']) @@ -925,6 +927,14 @@ class << MultiTkIp __getip._fromUTF8(str, encoding) end + def _thread_vwait(var) + __getip._thread_vwait(var) + end + + def _thread_tkwait(mode, target) + __getip._thread_tkwait(mode, target) + end + def _return_value __getip._return_value end @@ -1039,6 +1049,14 @@ class MultiTkIp @interp._fromUTF8(str, encoding) end + def _thread_vwait(var) + @interp._thread_vwait(var) + end + + def _thread_tkwait(mode, target) + @interp._thread_tkwait(mode, target) + end + def _return_value @interp._return_value end diff --git a/ext/tk/lib/tk.rb b/ext/tk/lib/tk.rb index 3dd3b3edb7..47148e43ce 100644 --- a/ext/tk/lib/tk.rb +++ b/ext/tk/lib/tk.rb @@ -1089,36 +1089,73 @@ module Tk extend Tk TCL_VERSION = INTERP._invoke("info", "tclversion").freeze - TK_VERSION = INTERP._invoke("set", "tk_version").freeze - TCL_PATCHLEVEL = INTERP._invoke("info", "patchlevel").freeze + + TK_VERSION = INTERP._invoke("set", "tk_version").freeze TK_PATCHLEVEL = INTERP._invoke("set", "tk_patchLevel").freeze - TCL_LIBRARY = INTERP._invoke("set", "tcl_library").freeze - TK_LIBRARY = INTERP._invoke("set", "tk_library").freeze - LIBRARY = INTERP._invoke("info", "library").freeze - - PLATFORM = Hash[*tk_split_simplelist(INTERP._invoke('array', 'get', - 'tcl_platform'))] - PLATFORM.each{|k, v| k.freeze; v.freeze} - PLATFORM.freeze - - TK_PREV = {} - Hash[*tk_split_simplelist(INTERP._invoke('array','get','tkPriv'))].each{|k,v| - k.freeze - case v - when /^-?\d+$/ - TK_PREV[k] = v.to_i - when /^-?\d+\.?\d*(e[-+]?\d+)?$/ - TK_PREV[k] = v.to_f - else - TK_PREV[k] = v.freeze - end - } - TK_PREV.freeze - JAPANIZED_TK = (INTERP._invoke("info", "commands", "kanji") != "").freeze + def Tk.const_missing(sym) + case(sym) + when :TCL_LIBRARY + INTERP._invoke("set", "tcl_library").freeze + + when :TK_LIBRARY + INTERP._invoke("set", "tk_library").freeze + + when :LIBRARY + INTERP._invoke("info", "library").freeze + + #when :PKG_PATH, :PACKAGE_PATH, :TCL_PACKAGE_PATH + # tk_split_simplelist(INTERP._invoke('set', 'tcl_pkgPath')) + + #when :LIB_PATH, :LIBRARY_PATH, :TCL_LIBRARY_PATH + # tk_split_simplelist(INTERP._invoke('set', 'tcl_libPath')) + + when :PLATFORM, :TCL_PLATFORM + Hash[*tk_split_simplelist(INTERP._invoke('array', 'get', + 'tcl_platform'))] + + when :ENV + Hash[*tk_split_simplelist(INTERP._invoke('array', 'get', 'env'))] + + #when :AUTO_PATH #<=== + # tk_split_simplelist(INTERP._invoke('set', 'auto_path')) + + #when :AUTO_OLDPATH + # tk_split_simplelist(INTERP._invoke('set', 'auto_oldpath')) + + when :AUTO_INDEX + Hash[*tk_split_simplelist(INTERP._invoke('array', 'get', 'auto_index'))] + + when :PRIV, :PRIVATE, :TK_PRIV + priv = {} + if INTERP._invoke('info', 'vars', 'tk::Priv') != "" + var_nam = 'tk::Priv' + else + var_nam = 'tkPriv' + end + Hash[*tk_split_simplelist(INTERP._invoke('array', 'get', + var_nam))].each{|k,v| + k.freeze + case v + when /^-?\d+$/ + priv[k] = v.to_i + when /^-?\d+\.?\d*(e[-+]?\d+)?$/ + priv[k] = v.to_f + else + priv[k] = v.freeze + end + } + priv + + else + raise NameError, 'uninitialized constant Tk::' + sym.id2name + end + end + + def root TkRoot.new end @@ -1709,7 +1746,8 @@ class TkVariable include Comparable - TkCommandNames = ['tkwait'.freeze].freeze + #TkCommandNames = ['tkwait'.freeze].freeze + TkCommandNames = ['vwait'.freeze].freeze #TkVar_CB_TBL = {} #TkVar_ID_TBL = {} @@ -1768,8 +1806,38 @@ class TkVariable end end - def wait - INTERP._eval("tkwait variable #{@id}") + def wait(on_thread = false, check_root = false) + if $SAFE >= 4 + fail SecurityError, "can't wait variable at $SAFE >= 4" + end + if on_thread + if check_root + INTERP._thread_tkwait('variable', @id) + else + INTERP._thread_vwait(@id) + end + else + if check_root + INTERP._invoke('tkwait', 'variable', @id) + else + INTERP._invoke('vwait', @id) + end + end + end + def eventloop_wait(check_root = false) + wait(false, check_root) + end + def thread_wait(check_root = false) + wait(true, check_root) + end + def tkwait(on_thread = true) + wait(on_thread, true) + end + def eventloop_tkwait + wait(false, true) + end + def thread_tkwait + wait(true, true) end def id @@ -2178,8 +2246,13 @@ module Tk end end AUTO_PATH = TkVarAccess.new('auto_path', auto_path) + AUTO_OLDPATH = TkVarAccess.new('auto_oldpath', auto_path) TCL_PACKAGE_PATH = TkVarAccess.new('tcl_pkgPath') + PACKAGE_PATH = TCL_PACKAGE_PATH + + TCL_LIBRARY_PATH = TkVarAccess.new('tcl_libPath') + LIBRARY_PATH = TCL_LIBRARY_PATH TCL_PRECISION = TkVarAccess.new('tcl_precision') end @@ -4167,14 +4240,50 @@ class TkWindow= 4 + fail SecurityError, "can't wait visibility at $SAFE >= 4" + end + if on_thread + INTERP._thread_tkwait('visibility', path) + else + INTERP._invoke('tkwait', 'visibility', path) + end + end + def eventloop_wait_visibility + wait_visibility(false) + end + def thread_wait_visibility + wait_visibility(true) end alias wait wait_visibility + alias tkwait wait_visibility + alias eventloop_wait eventloop_wait_visibility + alias eventloop_tkwait eventloop_wait_visibility + alias eventloop_tkwait_visibility eventloop_wait_visibility + alias thread_wait thread_wait_visibility + alias thread_tkwait thread_wait_visibility + alias thread_tkwait_visibility thread_wait_visibility - def wait_destroy - tk_call 'tkwait', 'window', epath + def wait_destroy(on_thread = true) + if $SAFE >= 4 + fail SecurityError, "can't wait destroy at $SAFE >= 4" + end + if on_thread + INTERP._thread_tkwait('window', epath) + else + INTERP._invoke('tkwait', 'window', epath) + end end + def eventloop_wait_destroy + wait_destroy(false) + end + def thread_wait_destroy + wait_destroy(true) + end + alias tkwait_destroy wait_destroy + alias eventloop_tkwait_destroy eventloop_wait_destroy + alias thread_tkwait_destroy thread_wait_destroy def bindtags(taglist=nil) if taglist diff --git a/ext/tk/lib/tkafter.rb b/ext/tk/lib/tkafter.rb index 239db4b5c9..663b977ed2 100644 --- a/ext/tk/lib/tkafter.rb +++ b/ext/tk/lib/tkafter.rb @@ -82,6 +82,7 @@ class TkTimer if @running == false || @proc_max == 0 || @do_loop == 0 Tk_CBTBL.delete(@id) ;# for GC @running = false + @wait_var.value = 0 return end if @current_pos >= @proc_max @@ -90,6 +91,7 @@ class TkTimer else Tk_CBTBL.delete(@id) ;# for GC @running = false + @wait_var.value = 0 return end end @@ -114,6 +116,8 @@ class TkTimer @id = Tk_CBID.join Tk_CBID[1].succ! + @wait_var = TkVariable.new(0) + # @cb_cmd = TkCore::INTERP.get_cb_entry(self.method(:do_callback)) @cb_cmd = TkCore::INTERP.get_cb_entry(proc{ begin @@ -338,6 +342,7 @@ class TkTimer def cancel @running = false + @wait_var.value = 0 tk_call 'after', 'cancel', @after_id if @after_id @after_id = nil Tk_CBTBL.delete(@id) ;# for GC @@ -378,6 +383,30 @@ class TkTimer nil end end + + def wait(on_thread = true, check_root = false) + if $SAFE >= 4 + fail SecurityError, "can't wait timer at $SAFE >= 4" + end + return self unless @running + @wait_var.wait(on_thread, check_root) + self + end + def eventloop_wait(check_root = false) + wait(false, check_root) + end + def thread_wait(check_root = false) + wait(true, check_root) + end + def tkwait(on_thread = true) + wait(on_thread, true) + end + def eventloop_tkwait + wait(false, true) + end + def thread_tkwait + wait(true, true) + end end TkAfter = TkTimer