From: Hidetoshi NAGAI Date: 2005-02-09T18:06:42+09:00 Subject: [ruby-dev:25663] Re: some problems on ext/tk/sample/**/*.rb 永井@知能．九工大です． From: H.Yamamoto Subject: [ruby-dev:25656] Re: some problems on ext/tk/sample/**/*.rb Date: Tue, 8 Feb 2005 15:37:00 +0900 Message-ID: <20050208153646.6DDB8540.ocean@m2.ccsnet.ne.jp> > 試した限りでは落ちなくなったようです。ただ、multi-ip の > サンプルがうまく動いていないようでした。 これについてはオオボケをかましてました． その修正 + α を行いましたのでお試し頂ければ幸いです． CVS HEAD からの差分になってます． > menu_spec = [ > [['File', 0], > ['exit(Crash)', proc{exit}, 0]] > ] > > TkMenubar.new(nil, menu_spec).pack > Tk.mainloop > > でメニューから終了すると、画面中央に一瞬何かのウィンドウが表示される > ことがあります。すぐ閉じるので、なんて書いてあるのかは読めません。 こちらについても少しは対策してみたつもりですが， 問題の現象を手元で再現できないため，確信が持てません． 結果を報告頂けますと助かります． Index: tcltklib.c =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/tcltklib.c,v retrieving revision 1.2 diff -u -r1.2 tcltklib.c --- tcltklib.c 31 Jan 2005 04:14:50 -0000 1.2 +++ tcltklib.c 9 Feb 2005 08:53:11 -0000 @@ -4,7 +4,7 @@ * Oct. 24, 1997 Y. Matsumoto */ -#define TCLTKLIB_RELEASE_DATE "2005-01-28" +#define TCLTKLIB_RELEASE_DATE "2005-02-09" #include "ruby.h" #include "rubysig.h" @@ -73,10 +73,6 @@ /* finalize_proc_name */ static char *finalize_hook_name = "INTERP_FINALIZE_HOOK"; -/* to cancel remained after-scripts when deleting IP */ -#define CANCEL_AFTER_SCRIPTS "__ruby_tcltklib_cancel_after_scripts__" -#define DEF_CANCEL_AFTER_SCRIPTS_PROC "proc __ruby_tcltklib_cancel_after_scripts__ {} {foreach id [after info] {after cancel $id}}" - /* for callback break & continue */ static VALUE eTkCallbackReturn; static VALUE eTkCallbackBreak; @@ -106,6 +102,9 @@ static VALUE ip_invoke_real _((int, VALUE*, VALUE)); static VALUE ip_invoke _((int, VALUE*, VALUE)); +static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); + + /* from tkAppInit.c */ #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4) @@ -148,6 +147,18 @@ VALUE thread; }; +struct call_queue { + Tcl_Event ev; + VALUE (*func)(); + int argc; + VALUE *argv; + VALUE interp; + int *done; + int safe_level; + VALUE result; + VALUE thread; +}; + void invoke_queue_mark(struct invoke_queue *q) { @@ -164,9 +175,26 @@ rb_gc_mark(q->thread); } +void +call_queue_mark(struct call_queue *q) +{ + int i; + + for(i = 0; i < q->argc; i++) { + rb_gc_mark(q->argv[i]); + } + + rb_gc_mark(q->interp); + rb_gc_mark(q->result); + rb_gc_mark(q->thread); +} + static VALUE eventloop_thread; static VALUE watchdog_thread; + +static VALUE rbtk_pending_exception; + Tcl_Interp *current_interp; /* @@ -204,6 +232,20 @@ static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **)); #endif +/*----------------------------*/ +/* use Tcl internal functions */ +/*----------------------------*/ +#ifndef TCL_NAMESPACE_DEBUG +#define TCL_NAMESPACE_DEBUG 0 +#endif + +#if TCL_NAMESPACE_DEBUG + +#if TCL_MAJOR_VERSION >= 8 +EXTERN struct TclIntStubs *tclIntStubsPtr; +#endif + +/*-- Tcl_GetCurrentNamespace --*/ #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 /* Tcl7.x doesn't have namespace support. */ /* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */ @@ -213,26 +255,186 @@ # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # ifndef Tcl_GetCurrentNamespace # ifndef FunctionNum_of_GetCurrentNamespace -# define FunctionNum_of_GetCurrentNamespace 124 +#define FunctionNum_of_GetCurrentNamespace 124 # endif -struct DummyTclIntStubs { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_GetCurrentNamespace])(); - Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *)); +struct DummyTclIntStubs_for_GetCurrentNamespace { + int magic; + struct TclIntStubHooks *hooks; + void (*func[FunctionNum_of_GetCurrentNamespace])(); + Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *)); }; -EXTERN struct TclIntStubs *tclIntStubsPtr; + #define Tcl_GetCurrentNamespace \ - (((struct DummyTclIntStubs *)tclIntStubsPtr)->tcl_GetCurrentNamespace) + (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace) +# endif +# endif +#endif + +/* namespace check */ +/* ip_null_namespace(Tcl_Interp *interp) */ +#if TCL_MAJOR_VERSION < 8 +#define ip_null_namespace(interp) (0) +#else /* support namespace */ +#define ip_null_namespace(interp) \ + (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL) +#endif + +/* rbtk_invalid_namespace(tcltkip *ptr) */ +#if TCL_MAJOR_VERSION < 8 +#define rbtk_invalid_namespace(ptr) (0) +#else /* support namespace */ +#define rbtk_invalid_namespace(ptr) \ + ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns) +#endif + +/*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/ +#if TCL_MAJOR_VERSION >= 8 +# ifndef CallFrame +typedef struct CallFrame { + Tcl_Namespace *nsPtr; + int dummy1; + int dummy2; + char *dummy3; + struct CallFrame *callerPtr; + struct CallFrame *callerVarPtr; + int level; + char *dummy7; + char *dummy8; + int dummy9; + char* dummy10; +} CallFrame; +# endif + +# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) +EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); +# endif +# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) +# ifndef TclGetFrame +# ifndef FunctionNum_of_GetFrame +#define FunctionNum_of_GetFrame 32 +# endif +struct DummyTclIntStubs_for_GetFrame { + int magic; + struct TclIntStubHooks *hooks; + void (*func[FunctionNum_of_GetFrame])(); + int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **)); +}; +#define TclGetFrame \ + (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame) +# endif +# endif + +# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) +EXTERN void Tcl_PopCallFrame _((Tcl_Interp *)); +EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); +# endif +# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) +# ifndef Tcl_PopCallFrame +# ifndef FunctionNum_of_PopCallFrame +#define FunctionNum_of_PopCallFrame 128 +# endif +struct DummyTclIntStubs_for_PopCallFrame { + int magic; + struct TclIntStubHooks *hooks; + void (*func[FunctionNum_of_PopCallFrame])(); + void (*tcl_PopCallFrame) _((Tcl_Interp *)); + int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); +}; + +#define Tcl_PopCallFrame \ + (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame) +#define Tcl_PushCallFrame \ + (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame) # endif # endif + +#else /* Tcl7.x */ +# ifndef CallFrame +typedef struct CallFrame { + Tcl_HashTable varTable; + int level; + int argc; + char **argv; + struct CallFrame *callerPtr; + struct CallFrame *callerVarPtr; +} CallFrame; +# endif +# ifndef Tcl_CallFrame +#define Tcl_CallFrame CallFrame +# endif + +# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) +EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); +# endif + +# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) +typedef struct DummyInterp { + char *dummy1; + char *dummy2; + int dummy3; + Tcl_HashTable dummy4; + Tcl_HashTable dummy5; + Tcl_HashTable dummy6; + int numLevels; + int maxNestingDepth; + CallFrame *framePtr; + CallFrame *varFramePtr; +} DummyInterp; + +static void +Tcl_PopCallFrame(interp) + Tcl_Interp *interp; +{ + DummyInterp *iPtr = (DummyInterp*)interp; + CallFrame *frame = iPtr->varFramePtr; + + /* **** DUMMY **** */ + iPtr->framePtr = frame.callerPtr; + iPtr->varFramePtr = frame.callerVarPtr; + + return TCL_OK; +} + +/* dummy */ +#define Tcl_Namespace char + +static int +Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) + Tcl_Interp *interp; + Tcl_CallFrame *framePtr; + Tcl_Namespace *nsPtr; + int isProcCallFrame; +{ + DummyInterp *iPtr = (DummyInterp*)interp; + CallFrame *frame = (CallFrame *)framePtr; + + /* **** DUMMY **** */ + Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); + if (iPtr->varFramePtr != NULL) { + frame.level = iPtr->varFramePtr->level + 1; + } else { + frame.level = 1; + } + frame.callerPtr = iPtr->framePtr; + frame.callerVarPtr = iPtr->varFramePtr; + iPtr->framePtr = &frame; + iPtr->varFramePtr = &frame; + + return TCL_OK; +} +# endif + #endif +#endif /* TCL_NAMESPACE_DEBUG */ + /*---- class TclTkIp ----*/ struct tcltkip { Tcl_Interp *ip; /* the interpreter */ +#if TCL_NAMESPACE_DEBUG Tcl_Namespace *default_ns; /* default namespace */ +#endif int has_orig_exit; /* has original 'exit' command ? */ Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */ int ref_count; /* reference count of rbtk_preserve_ip call */ @@ -248,37 +450,28 @@ Data_Get_Struct(self, struct tcltkip, ptr); if (ptr == 0) { - rb_raise(rb_eTypeError, "uninitialized TclTkIp"); + /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */ + return((struct tcltkip *)NULL); + } + if (ptr->ip == (Tcl_Interp*)NULL) { + /* rb_raise(rb_eRuntimeError, "deleted IP"); */ } return ptr; } -/* namespace check */ -/* ip_null_namespace(Tcl_Interp *interp) */ -#if TCL_MAJOR_VERSION < 8 -#define ip_null_namespace(interp) (0) -#else /* support namespace */ -#define ip_null_namespace(interp) \ - (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL) -#endif - -/* rbtk_invalid_namespace(tcltkip *ptr) */ -#if TCL_MAJOR_VERSION < 8 -#define rbtk_invalid_namespace(ptr) (0) -#else /* support namespace */ -#define rbtk_invalid_namespace(ptr) \ - ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns) -#endif - - /* increment/decrement reference count of tcltkip */ static int rbtk_preserve_ip(ptr) struct tcltkip *ptr; { ptr->ref_count++; - Tcl_Preserve((ClientData)ptr->ip); + if (ptr->ip == (Tcl_Interp*)NULL) { + /* deleted IP */ + ptr->ref_count = 0; + } else { + Tcl_Preserve((ClientData)ptr->ip); + } return(ptr->ref_count); } @@ -289,6 +482,9 @@ ptr->ref_count--; if (ptr->ref_count < 0) { ptr->ref_count = 0; + } else if (ptr->ip == (Tcl_Interp*)NULL) { + /* deleted IP */ + ptr->ref_count = 0; } else { Tcl_Release((ClientData)ptr->ip); } @@ -454,7 +650,7 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return get_eventloop_tick(self); } @@ -507,7 +703,7 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return get_no_event_wait(self); } @@ -563,7 +759,7 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return get_eventloop_weight(self); } @@ -659,7 +855,7 @@ rb_secure(4); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return lib_evloop_abort_on_exc(self); } @@ -734,6 +930,15 @@ found_event = Tcl_DoOneEvent(event_flag); + if (rbtk_pending_exception != 0) { + volatile VALUE exc = rbtk_pending_exception; + DUMP1("find a pending exception"); + rbtk_pending_exception = 0; + if (rb_obj_is_kind_of(exc, rb_eException)) { + rb_exc_raise(exc); + } + } + if (update_flag != 0) { if (found_event) { DUMP1("next update loop"); @@ -759,7 +964,7 @@ } } else { - int tick_counter; + int st, tick_counter; DUMP1("there are other threads"); event_loop_wait_event = 1; @@ -781,15 +986,31 @@ } } - if (Tcl_DoOneEvent(event_flag)) { - tick_counter++; - } else { - if (update_flag != 0) { - DUMP1("update complete"); - return 0; + if (eventloop_thread == 0 || current == eventloop_thread) { + st = Tcl_DoOneEvent(event_flag); + + if (rbtk_pending_exception != 0) { + volatile VALUE exc = rbtk_pending_exception; + DUMP1("find a pending exception"); + rbtk_pending_exception = 0; + if (rb_obj_is_kind_of(exc, rb_eException)) { + rb_exc_raise(exc); + } + } + + if (st) { + tick_counter++; + } else { + if (update_flag != 0) { + DUMP1("update complete"); + return 0; + } + tick_counter += no_event_tick; + rb_thread_wait_for(t); } - tick_counter += no_event_tick; - rb_thread_wait_for(t); + } else { + DUMP2("sleep eventloop %lx", current); + rb_thread_stop(); } if (watchdog_thread != 0 && eventloop_thread != current) { @@ -851,12 +1072,22 @@ { Tk_DeleteTimerHandler(timer_token); timer_token = (Tcl_TimerToken)NULL; - 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; + + DUMP2("eventloop-ensure: current-thread : %lx", rb_thread_current()); + DUMP2("eventloop-ensure: eventloop-thread : %lx", eventloop_thread); + while (eventloop_thread != rb_thread_current()) { + DUMP2("current-eventloop %lx waits for child", rb_thread_current()); + rb_thread_stop(); } + + DUMP2("eventloop-enshure: eventloop-thread -> %lx", parent_evloop); + eventloop_thread = parent_evloop; + if (eventloop_thread != 0) { + DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread); + rb_thread_wakeup(eventloop_thread); + } + DUMP2("FINISH eventloop %lx", rb_thread_current()); + return Qnil; } @@ -864,10 +1095,19 @@ lib_eventloop_launcher(check_rootwidget) VALUE check_rootwidget; { - VALUE parent_evloop = eventloop_thread; + volatile VALUE parent_evloop = eventloop_thread; eventloop_thread = rb_thread_current(); + if (parent_evloop != 0) { + DUMP2("wait for stop of parent_evloop %lx", parent_evloop); + while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) { + DUMP2("parent_evloop %lx doesn't stop", parent_evloop); + rb_thread_run(parent_evloop); + } + DUMP1("succeed to stop parent"); + } + if (ruby_debug) { fprintf(stderr, "tcltklib: eventloop-thread : %lx -> %lx\n", parent_evloop, eventloop_thread); @@ -906,7 +1146,8 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return Qnil; } @@ -1011,7 +1252,7 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return Qnil; } @@ -1034,6 +1275,10 @@ int flags; int found_event; + if (eventloop_thread) { + rb_raise(rb_eRuntimeError, "eventloop is already running"); + } + if (rb_scan_args(argc, argv, "01", &vflags) == 0) { flags = TCL_ALL_EVENTS | TCL_DONT_WAIT; } else { @@ -1050,7 +1295,8 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return Qfalse; } @@ -1064,6 +1310,15 @@ /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */ found_event = Tcl_DoOneEvent(flags); + if (rbtk_pending_exception != 0) { + volatile VALUE exc = rbtk_pending_exception; + DUMP1("find a pending exception"); + rbtk_pending_exception = 0; + if (rb_obj_is_kind_of(exc, rb_eException)) { + rb_exc_raise(exc); + } + } + if (found_event) { return Qtrue; } else { @@ -1347,8 +1602,23 @@ /* ruby command has 1 arg. */ if (argc != 2) { - rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", - argc - 1); +#if 0 + rb_raise(rb_eArgError, + "wrong number of arguments (%d for 1)", argc - 1); +#else + char buf[sizeof(int)*8 + 1]; + Tcl_ResetResult(interp); + sprintf(buf, "%d", argc-1); + Tcl_AppendResult(interp, "wrong number of arguments (", + buf, " for 1)", (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eArgError, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result); +#endif + return TCL_ERROR; +#endif } /* allocate */ @@ -1435,9 +1705,15 @@ return TCL_CONTINUE; } else if (eclass == rb_eSystemExit) { + ip_set_exc_message(interp, res); + rbtk_pending_exception = res; + return TCL_ERROR; + +#if 0 thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; +#if 0 /* REMOVE : fail to rescue SystemExit */ /* Tcl_Eval(interp, "destroy ."); */ if (Tk_GetNumMainWindows() > 0) { Tk_Window main_win = Tk_MainWindow(interp); @@ -1445,6 +1721,7 @@ Tk_DestroyWindow(main_win); } } +#endif /* StringValue(res); */ res = rb_funcall(res, ID_message, 0, 0); @@ -1454,6 +1731,7 @@ rb_thread_critical = thr_crit_bup; rb_raise(rb_eSystemExit, RSTRING(res)->ptr); +#endif } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { VALUE reason = rb_ivar_get(res, ID_at_reason); @@ -1707,7 +1985,19 @@ VALUE old_gc; if (argc < 3) { +#if 0 rb_raise(rb_eArgError, "too few arguments"); +#else + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "too few arguments", (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eArgError, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result); +#endif + return TCL_ERROR; +#endif } /* allocate */ @@ -1744,8 +2034,21 @@ free(buf); } if (NIL_P(receiver)) { - rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'", - str); +#if 0 + rb_raise(rb_eArgError, + "unknown class/module/global-variable '%s'", str); +#else + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "unknown class/module/global-variable '", + str, "'", (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eArgError, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result); +#endif + return TCL_ERROR; +#endif } /* get metrhod */ @@ -1835,6 +2138,7 @@ thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; +#if 0 /* REMOVE : fail to rescue SystemExit */ /* Tcl_Eval(interp, "destroy ."); */ if (Tk_GetNumMainWindows() > 0) { Tk_Window main_win = Tk_MainWindow(interp); @@ -1842,6 +2146,7 @@ Tk_DestroyWindow(main_win); } } +#endif /* StringValue(res); */ res = rb_funcall(res, ID_message, 0, 0); @@ -1850,8 +2155,21 @@ rb_thread_critical = thr_crit_bup; +#if 0 rb_raise(rb_eSystemExit, RSTRING(res)->ptr); - +#else + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "raise SystemExit on `ruby_cmd'", + (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, + interp->result); +#endif + return TCL_ERROR; +#endif } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { VALUE reason = rb_ivar_get(res, ID_at_reason); @@ -1926,7 +2244,11 @@ char *argv[]; #endif { - if (!Tcl_InterpDeleted(interp) && !ip_null_namespace(interp)) { + if (!Tcl_InterpDeleted(interp) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(interp) +#endif + ) { Tcl_Preserve(interp); Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); Tcl_Release(interp); @@ -1961,12 +2283,42 @@ #endif if (rb_safe_level() >= 4) { +#if 0 rb_raise(rb_eSecurityError, "Insecure operation `exit' at level %d", rb_safe_level()); +#else + char buf[sizeof(int)*8 + 1]; + Tcl_ResetResult(interp); + sprintf(buf, "%d", rb_safe_level()); + Tcl_AppendResult(interp, "Insecure operation `exit' at level ", + buf, (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eSecurityError, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eSecurityError, + interp->result); +#endif + return TCL_ERROR; +#endif } else if (Tcl_IsSafe(interp)) { +#if 0 rb_raise(rb_eSecurityError, "Insecure operation `exit' on a safe interpreter"); +#else + Tcl_AppendResult(interp, + "Insecure operation `exit' on a safe interpreter", + (char *)NULL); +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eSecurityError, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eSecurityError, + interp->result); +#endif + return TCL_ERROR; +#endif #if 0 } else if (Tcl_GetMaster(interp) != (Tcl_Interp *)NULL) { Tcl_Preserve(interp); @@ -1981,10 +2333,18 @@ switch(argc) { case 1: - rb_exit(0); /* not return if succeed */ - + /* rb_exit(0); */ /* not return if succeed */ Tcl_AppendResult(interp, "fail to call \"", cmd, "\"", (char *)NULL); + +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, interp->result); +#endif + rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0)); + return TCL_ERROR; case 2: @@ -2002,11 +2362,21 @@ } param = argv[1]; #endif - rb_exit(state); /* not return if succeed */ + /* rb_exit(state); */ /* not return if succeed */ Tcl_AppendResult(interp, "fail to call \"", cmd, " ", param, "\"", (char *)NULL); + +#if TCL_MAJOR_VERSION >= 8 + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, + Tcl_GetStringResult(interp)); +#else + rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, interp->result); +#endif + rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state)); + return TCL_ERROR; + default: /* arguemnt error */ Tcl_AppendResult(interp, @@ -3275,12 +3645,19 @@ VALUE self; VALUE var; { - VALUE argv[2]; + VALUE *argv; + VALUE retval; volatile VALUE cmd_str = rb_str_new2("thread_vwait"); + argv = ALLOC_N(VALUE, 2); argv[0] = cmd_str; argv[1] = var; - return ip_invoke_real(2, argv, self); + + retval = ip_invoke_real(2, argv, self); + + free(argv); + + return retval; } static VALUE @@ -3289,13 +3666,20 @@ VALUE mode; VALUE target; { - VALUE argv[3]; + VALUE *argv; + VALUE retval; volatile VALUE cmd_str = rb_str_new2("thread_tkwait"); + argv = ALLOC_N(VALUE, 3); argv[0] = cmd_str; argv[1] = mode; argv[2] = target; - return ip_invoke_real(3, argv, self); + + retval = ip_invoke_real(3, argv, self); + + free(argv); + + return retval; } /* destroy interpreter */ @@ -3329,7 +3713,11 @@ char *slave_name; int i, len; - if (Tcl_InterpDeleted(ip) || ip_null_namespace(ip)) { + if (Tcl_InterpDeleted(ip) +#if TCL_NAMESPACE_DEBUG + || ip_null_namespace(ip) +#endif + ) { DUMP2("call delete_slaves() for deleted ip(%lx)", ip); return; } @@ -3370,20 +3758,22 @@ Tcl_Preserve(slave); - if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave) && - Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) { + if (!Tcl_InterpDeleted(slave) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(slave) +#endif + && Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) { DUMP2("call finalize hook proc '%s'", finalize_hook_name); Tcl_Eval(slave, finalize_hook_name); } - if (!Tcl_InterpDeleted(slave) && - Tcl_Eval(slave, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave) && - Tcl_GetCommandInfo(slave, CANCEL_AFTER_SCRIPTS, &info)) { - DUMP2("call cancel after scripts proc '%s'", - CANCEL_AFTER_SCRIPTS); - Tcl_Eval(slave, CANCEL_AFTER_SCRIPTS); - } + if (!Tcl_InterpDeleted(slave) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(slave) +#endif + ) { + DUMP1("call cancel after scripts"); + Tcl_Eval(slave, "foreach id [after info] {after cancel $id}"); } /* delete slaves of slave */ @@ -3408,69 +3798,124 @@ Tcl_Release(ip); } -static void -ip_free(ptr) - struct tcltkip *ptr; + +static int +ip_free_core(ip) + Tcl_Interp *ip; { Tcl_CmdInfo info; int thr_crit_bup; - char* argv[2]; - DUMP2("free Tcl Interp %lx", ptr->ip); - if (ptr) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; + /* deleted ipterp ? */ + if (ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ip)) { + /* deleted IP --> ignore */ + return 1; + } - DUMP2("IP ref_count = %d", ptr->ref_count); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)) { - DUMP2("IP(%lx) is not deleted", ptr->ip); - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); + Tcl_Preserve(ip); - delete_slaves(ptr->ip); + delete_slaves(ip); - Tcl_ResetResult(ptr->ip); + Tcl_ResetResult(ip); - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) - && Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { - DUMP2("call finalize hook proc '%s'", finalize_hook_name); - Tcl_Eval(ptr->ip, finalize_hook_name); - } + if (!Tcl_InterpDeleted(ip) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(ip) +#endif + && Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(ip, finalize_hook_name); + } - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) - && Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) - && Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { - DUMP2("call cancel after scripts proc '%s'", - CANCEL_AFTER_SCRIPTS); - Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS); - } - } + if (!Tcl_InterpDeleted(ip) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(ip) +#endif + ) { + DUMP1("call cancel aftern scripts"); + Tcl_Eval(ip, "foreach id [after info] {after cancel $id}"); + } - /* del_root(ptr->ip); */ + /* del_root(ip); */ - DUMP1("delete interp"); - /* while(!rbtk_InterpDeleted(ptr->ip)) { */ - if (!Tcl_InterpDeleted(ptr->ip)) { - DUMP2("delete ip(%lx)", ptr->ip); - Tcl_DeleteInterp(ptr->ip); - } + /* while(!rbtk_InterpDeleted(ip)) { */ + if (!Tcl_InterpDeleted(ip)) { + DUMP2("delete ip(%lx)", ip); + Tcl_DeleteInterp(ip); + } - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - } + Tcl_Release(ip); - rbtk_release_ip(ptr); - DUMP2("IP ref_count = %d", ptr->ref_count); + rb_thread_critical = thr_crit_bup; - free(ptr); + return 1; +} - rb_thread_critical = thr_crit_bup; +struct ip_free_queue { + Tcl_Event ev; + Tcl_Interp *ip; +}; + +static int +ip_free_queue_handler(evPtr, flags) + Tcl_Event *evPtr; + int flags; +{ + struct ip_free_queue *ptr = (struct ip_free_queue *)evPtr; + int st; + + st = ip_free_core(ptr->ip); + + Tcl_Release(evPtr); + + return st; +} + +static void +ip_free(ptr) + struct tcltkip *ptr; +{ + struct ip_free_queue *q; + + DUMP2("free Tcl Interp %lx", ptr->ip); + if (ptr) { + if ( ptr->ip != (Tcl_Interp*)NULL + && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL + && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) { + DUMP2("parent IP(%lx) is not deleted", Tcl_GetMaster(ptr->ip)); + DUMP2("slave IP(%lx) should not be deleted", ptr->ip); + free(ptr); + return; + } + + if (ptr->ip == (Tcl_Interp*)NULL) { + DUMP1("ip_free is called for deleted IP"); + free(ptr); + return; + } + + if (eventloop_thread != 0 && rb_thread_current() != eventloop_thread) { + /* queueing */ + q = (struct ip_free_queue*)Tcl_Alloc(sizeof(struct ip_free_queue)); + Tcl_Preserve(q); + q->ip = ptr->ip; + q->ev.proc = ip_free_queue_handler; + Tcl_QueueEvent(&(q->ev), TCL_QUEUE_HEAD); + } else { + /* direct call */ + ip_free_core(ptr->ip); + } + + free(ptr); } + DUMP1("complete freeing Tcl Interp"); } + /* create and initialize interpreter */ static VALUE ip_alloc _((VALUE)); static VALUE @@ -3494,7 +3939,9 @@ /* security check */ if (ruby_safe_level >= 4) { - rb_raise(rb_eSecurityError, "Cannot create a TclTkIp object at level %d", ruby_safe_level); + rb_raise(rb_eSecurityError, + "Cannot create a TclTkIp object at level %d", + ruby_safe_level); } /* create object */ @@ -3513,12 +3960,14 @@ } #if TCL_MAJOR_VERSION >= 8 +#if TCL_NAMESPACE_DEBUG DUMP1("get current namespace"); if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip)) == (Tcl_Namespace*)NULL) { rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace"); } #endif +#endif rbtk_preserve_ip(ptr); DUMP2("IP ref_count = %d", ptr->ref_count); @@ -3715,12 +4164,12 @@ } static VALUE -ip_create_slave(argc, argv, self) +ip_create_slave_core(interp, argc, argv) + VALUE interp; int argc; VALUE *argv; - VALUE self; { - struct tcltkip *master = get_ip(self); + struct tcltkip *master = get_ip(interp); struct tcltkip *slave = ALLOC(struct tcltkip); VALUE safemode; VALUE name; @@ -3728,15 +4177,22 @@ int thr_crit_bup; Tk_Window mainWin; - /* safe-mode check */ - if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { - safemode = Qfalse; + /* ip is deleted? */ + if (master == (struct tcltkip *)NULL || master->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(master->ip)) { + DUMP1("master-ip is deleted"); + return rb_exc_new2(rb_eRuntimeError, + "deleted master cannot create a new slave"); } + + name = argv[0]; + safemode = argv[1]; + if (Tcl_IsSafe(master->ip) == 1) { safe = 1; } else if (safemode == Qfalse || NIL_P(safemode)) { safe = 0; - rb_secure(4); + /* rb_secure(4); */ /* already checked */ } else { safe = 1; } @@ -3744,26 +4200,22 @@ thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; - /* ip is deleted? */ - if (Tcl_InterpDeleted(master->ip)) { - DUMP1("master-ip is deleted"); - rb_thread_critical = thr_crit_bup; - rb_raise(rb_eRuntimeError, "deleted master cannot create a new slave interpreter"); - } - /* create slave-ip */ slave->ref_count = 0; slave->allow_ruby_exit = 0; slave->return_value = 0; - slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe); + slave->ip = Tcl_CreateSlave(master->ip, RSTRING(name)->ptr, safe); if (slave->ip == NULL) { rb_thread_critical = thr_crit_bup; - rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter"); + return rb_exc_new2(rb_eRuntimeError, + "fail to create the new slave interpreter"); } #if TCL_MAJOR_VERSION >= 8 +#if TCL_NAMESPACE_DEBUG slave->default_ns = Tcl_GetCurrentNamespace(slave->ip); #endif +#endif rbtk_preserve_ip(slave); slave->has_orig_exit @@ -3783,28 +4235,72 @@ rb_thread_critical = thr_crit_bup; - return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave); + return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave); } -/* make ip "safe" */ static VALUE -ip_make_safe(self) +ip_create_slave(argc, argv, self) + int argc; + VALUE *argv; VALUE self; { - struct tcltkip *ptr = get_ip(self); + struct tcltkip *master = get_ip(self); + VALUE safemode; + VALUE name; + VALUE *callargv; + VALUE retval; + + /* ip is deleted? */ + if (master == (struct tcltkip *)NULL || master->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(master->ip)) { + DUMP1("master-ip is deleted"); + rb_raise(rb_eRuntimeError, + "deleted master cannot create a new slave interpreter"); + } + + /* safe-mode check */ + if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { + safemode = Qfalse; + } + if (Tcl_IsSafe(master->ip) != 1 + && (safemode == Qfalse || NIL_P(safemode))) { + rb_secure(4); + } + + callargv = ALLOC_N(VALUE, 2); + StringValue(name); + callargv[0] = name; + callargv[1] = safemode; + + retval = tk_funcall(ip_create_slave_core, 2, callargv, self); + + free(callargv); + + return retval; +} + +/* make ip "safe" */ +static VALUE +ip_make_safe_core(interp, argc, argv) + VALUE interp; + int argc; /* dummy */ + VALUE *argv; /* dummy */ +{ + struct tcltkip *ptr = get_ip(interp); Tk_Window mainWin; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); - rb_raise(rb_eRuntimeError, "interpreter is deleted"); + return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); } if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { #if TCL_MAJOR_VERSION >= 8 - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); + return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); #else /* TCL_MAJOR_VERSION < 8 */ - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); #endif } @@ -3822,7 +4318,23 @@ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); #endif - return self; + return interp; +} + +static VALUE +ip_make_safe(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self); } /* is safe? */ @@ -3833,7 +4345,8 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); rb_raise(rb_eRuntimeError, "interpreter is deleted"); } @@ -3853,7 +4366,8 @@ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); rb_raise(rb_eRuntimeError, "interpreter is deleted"); } @@ -3876,7 +4390,8 @@ rb_secure(4); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); rb_raise(rb_eRuntimeError, "interpreter is deleted"); } @@ -3918,11 +4433,19 @@ /* delete interpreter */ static VALUE -ip_delete(self) - VALUE self; +ip_delete_core(interp, argc, argv) + VALUE interp; + int argc; /* dummy */ + VALUE *argv; /* dummy */ { Tcl_CmdInfo info; - struct tcltkip *ptr = get_ip(self); + struct tcltkip *ptr = get_ip(interp); + + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL + || Tcl_InterpDeleted(ptr->ip)) { + DUMP1("delete deleted IP"); + return Qnil; + } /* Tcl_Preserve(ptr->ip); */ rbtk_preserve_ip(ptr); @@ -3931,20 +4454,22 @@ delete_slaves(ptr->ip); DUMP1("finalize operation"); - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) + if (!Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + && !rbtk_invalid_namespace(ptr) +#endif && Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { DUMP2("call finalize hook proc '%s'", finalize_hook_name); Tcl_Eval(ptr->ip, finalize_hook_name); } - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) - && Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr) - && Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { - DUMP2("call cancel after scripts proc '%s'", - CANCEL_AFTER_SCRIPTS); - Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS); - } + if (!Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + && !ip_null_namespace(ptr->ip) +#endif + ) { + DUMP1("call cancel after scripts"); + Tcl_Eval(ptr->ip, "foreach id [after info] {after cancel $id}"); } del_root(ptr->ip); @@ -3955,6 +4480,7 @@ DUMP2("delete ip(%lx)", ptr->ip); Tcl_DeleteInterp(ptr->ip); } + ptr->ip = (Tcl_Interp*)NULL; /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); @@ -3962,6 +4488,21 @@ return Qnil; } +static VALUE +ip_delete(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { + return Qnil; + } else { + return tk_funcall(ip_delete_core, 0, (VALUE*)NULL, self); + } +} + + /* is deleted? */ static VALUE ip_has_invalid_namespace_p(self) @@ -3969,11 +4510,20 @@ { struct tcltkip *ptr = get_ip(self); + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) { + /* deleted IP */ + return Qtrue; + } + +#if TCL_NAMESPACE_DEBUG if (rbtk_invalid_namespace(ptr)) { return Qtrue; } else { return Qfalse; } +#else + return Qfalse; +#endif } static VALUE @@ -3982,7 +4532,8 @@ { struct tcltkip *ptr = get_ip(self); - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL + || Tcl_InterpDeleted(ptr->ip)) { return Qtrue; } else { return Qfalse; @@ -4004,6 +4555,7 @@ va_list args; char buf[BUFSIZ]; VALUE einfo; + struct tcltkip *ptr = get_ip(interp); va_init_list(args,fmt); vsnprintf(buf, BUFSIZ, fmt, args); @@ -4011,7 +4563,9 @@ va_end(args); einfo = rb_exc_new2(exc, buf); rb_ivar_set(einfo, ID_at_interp, interp); - Tcl_ResetResult(get_ip(interp)->ip); + if (ptr) { + Tcl_ResetResult(ptr->ip); + } return einfo; } @@ -4073,6 +4627,175 @@ #endif } + +/* call Tcl/Tk functions on the eventloop thread */ +static VALUE +callq_safelevel_handler(arg, callq) + VALUE arg; + VALUE callq; +{ + struct call_queue *q; + + Data_Get_Struct(callq, struct call_queue, q); + DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); + rb_set_safe_level(q->safe_level); + return((q->func)(q->interp, q->argc, q->argv)); +} + +static int call_queue_handler _((Tcl_Event *, int)); +static int +call_queue_handler(evPtr, flags) + Tcl_Event *evPtr; + int flags; +{ + struct call_queue *q = (struct call_queue *)evPtr; + volatile VALUE ret; + volatile VALUE q_dat; + struct tcltkip *ptr; + + DUMP2("do_call_queue_handler : evPtr = %p", evPtr); + DUMP2("queue_handler thread : %lx", rb_thread_current()); + DUMP2("added by thread : %lx", q->thread); + + if (*(q->done)) { + DUMP1("processed by another event-loop"); + return 0; + } else { + DUMP1("process it on current event-loop"); + } + + /* process it */ + *(q->done) = 1; + + /* deleted ipterp ? */ + ptr = get_ip(q->interp); + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { + /* deleted IP --> ignore */ + return 1; + } + + /* check safe-level */ + if (rb_safe_level() != q->safe_level) { + /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ + q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,0,q); + ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat), + ID_call, 0); + rb_gc_force_recycle(q_dat); + } else { + DUMP2("call function (for caller thread:%lx)", q->thread); + DUMP2("call function (current thread:%lx)", rb_thread_current()); + ret = (q->func)(q->interp, q->argc, q->argv); + } + + /* set result */ + RARRAY(q->result)->ptr[0] = ret; + + /* complete */ + *(q->done) = -1; + + /* 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; +} + +static VALUE +tk_funcall(func, argc, argv, obj) + VALUE (*func)(); + int argc; + VALUE *argv; + VALUE obj; +{ + struct call_queue *callq; + int *alloc_done; + int thr_crit_bup; + volatile VALUE current = rb_thread_current(); + volatile VALUE ip_obj = obj; + volatile VALUE result; + volatile VALUE ret; + + + if (!NIL_P(ip_obj) && Tcl_InterpDeleted(get_ip(ip_obj)->ip)) { + return Qnil; + } + + if (eventloop_thread == 0 || current == eventloop_thread) { + if (eventloop_thread) { + DUMP2("tk_funcall from current eventloop %lx", current); + } else { + DUMP2("tk_funcall from thread:%lx but no eventloop", current); + } + result = (func)(ip_obj, argc, argv); + if (rb_obj_is_kind_of(result, rb_eException)) { + rb_exc_raise(result); + } + return result; + } + + DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* allocate memory (keep result) */ + alloc_done = (int*)ALLOC(int); + *alloc_done = 0; + + /* allocate memory (freed by Tcl_ServiceEvent) */ + callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); + Tcl_Preserve(callq); + + /* allocate result obj */ + result = rb_ary_new2(1); + RARRAY(result)->ptr[0] = Qnil; + RARRAY(result)->len = 1; + + /* construct event data */ + callq->done = alloc_done; + callq->func = func; + callq->argc = argc; + callq->argv = argv; + callq->interp = ip_obj; + callq->result = result; + callq->thread = current; + callq->safe_level = rb_safe_level(); + callq->ev.proc = call_queue_handler; + + /* add the handler to Tcl event queue */ + DUMP1("add handler"); + Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); + + rb_thread_critical = thr_crit_bup; + + /* wait for the handler to be processed */ + DUMP2("wait for handler (current thread:%lx)", current); + while(*alloc_done >= 0) { + rb_thread_stop(); + } + DUMP2("back from handler (current thread:%lx)", current); + + /* get result & free allocated memory */ + ret = RARRAY(result)->ptr[0]; + free(alloc_done); + + Tcl_Release(callq); + + /* exception? */ + if (rb_obj_is_kind_of(ret, rb_eException)) { + DUMP1("raise exception"); + rb_exc_raise(ret); + } + + DUMP1("exit tk_funcall"); + return ret; +} + + /* eval string in tcl by Tcl_Eval() */ static VALUE ip_eval_real(self, cmd_str, cmd_len) @@ -4098,7 +4821,12 @@ Tcl_IncrRefCount(cmd); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); Tcl_DecrRefCount(cmd); rb_thread_critical = thr_crit_bup; @@ -4118,8 +4846,15 @@ if (ptr->return_value == TCL_ERROR) { volatile VALUE exc; - exc = create_ip_exc(self, rb_eRuntimeError, - "%s", Tcl_GetStringResult(ptr->ip)); + + if (rbtk_pending_exception != 0) { + exc = rbtk_pending_exception; + rbtk_pending_exception = 0; + } else { + exc = create_ip_exc(self, rb_eRuntimeError, + "%s", Tcl_GetStringResult(ptr->ip)); + } + /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); @@ -4139,7 +4874,12 @@ DUMP2("Tcl_Eval(%s)", cmd_str); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); ptr->return_value = TCL_OK; return rb_tainted_str_new2(""); @@ -4152,7 +4892,14 @@ if (ptr->return_value == TCL_ERROR) { volatile VALUE exc; - exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); + + if (rbtk_pending_exception != 0) { + exc = rbtk_pending_exception; + rbtk_pending_exception = 0; + } else { + exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); + } + /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_exc_raise(exc); @@ -4334,19 +5081,26 @@ /* restart Tk */ static VALUE -lib_restart(self) - VALUE self; +lib_restart_core(interp, argc, argv) + VALUE interp; + int argc; /* dummy */ + VALUE *argv; /* dummy */ { volatile VALUE exc; - struct tcltkip *ptr = get_ip(self); + struct tcltkip *ptr = get_ip(interp); int thr_crit_bup; - rb_secure(4); + /* rb_secure(4); */ /* already checked */ /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); - rb_raise(rb_eRuntimeError, "interpreter is deleted"); + return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); } thr_crit_bup = rb_thread_critical; @@ -4361,11 +5115,13 @@ DUMP2("(TCL_Eval result) %d", ptr->return_value); Tcl_ResetResult(ptr->ip); +#if TCL_MAJOR_VERSION >= 8 /* delete namespace ( tested on tk8.4.5 ) */ ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat"); /* ignore ERROR */ DUMP2("(TCL_Eval result) %d", ptr->return_value); Tcl_ResetResult(ptr->ip); +#endif /* delete trace proc ( tested on tk8.4.5 ) */ ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings"); @@ -4382,7 +5138,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } } else { DUMP1("Tk_Init"); @@ -4391,7 +5147,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } } #else /* TCL_MAJOR_VERSION < 8 */ @@ -4400,7 +5156,7 @@ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); - rb_exc_raise(exc); + return exc; } #endif @@ -4412,6 +5168,30 @@ return Qnil; } +static VALUE +lib_restart(self) + VALUE self; +{ + volatile VALUE exc; + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + + rb_secure(4); + + /* ip is deleted? */ + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self); +} + static VALUE ip_restart(self) @@ -4422,7 +5202,8 @@ rb_secure(4); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); rb_raise(rb_eRuntimeError, "interpreter is deleted"); } @@ -4454,12 +5235,15 @@ if (NIL_P(ip_obj)) { interp = (Tcl_Interp *)NULL; } else { - interp = get_ip(ip_obj)->ip; + ptr = get_ip(ip_obj); /* ip is deleted? */ - if (Tcl_InterpDeleted(interp)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); interp = (Tcl_Interp *)NULL; + } else { + interp = ptr->ip; } } @@ -4597,6 +5381,8 @@ if (NIL_P(ip_obj)) { interp = (Tcl_Interp *)NULL; + } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { + interp = (Tcl_Interp *)NULL; } else { interp = get_ip(ip_obj)->ip; } @@ -4833,7 +5619,12 @@ ptr = get_ip(interp); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } @@ -4908,6 +5699,15 @@ /* exception on mainloop */ if (ptr->return_value == TCL_ERROR) { if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { + + if (rbtk_pending_exception != 0) { + volatile VALUE exc; + DUMP1("find a pending exception"); + exc = rbtk_pending_exception; + rbtk_pending_exception = 0; + return exc; + } + #if TCL_MAJOR_VERSION >= 8 return create_ip_exc(interp, rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); @@ -5062,7 +5862,7 @@ ptr = get_ip(interp); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } @@ -5258,7 +6058,8 @@ ptr = get_ip(self); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip)) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } @@ -5284,21 +6085,22 @@ return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); } + /* access Tcl variables */ static VALUE -ip_get_variable(self, varname_arg, flag_arg) - VALUE self; - VALUE varname_arg; - VALUE flag_arg; +ip_get_variable_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; { - struct tcltkip *ptr = get_ip(self); + struct tcltkip *ptr = get_ip(interp); int thr_crit_bup; volatile VALUE varname, flag; - varname = varname_arg; - flag = flag_arg; + varname = argv[0]; + flag = argv[1]; - StringValue(varname); + /* StringValue(varname); */ #if TCL_MAJOR_VERSION >= 8 { @@ -5315,7 +6117,12 @@ Tcl_IncrRefCount(nameobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); rb_thread_critical = thr_crit_bup; @@ -5339,7 +6146,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } Tcl_IncrRefCount(ret); @@ -5379,7 +6186,12 @@ char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5399,7 +6211,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } strval = rb_tainted_str_new2(ret); @@ -5413,26 +6225,44 @@ } static VALUE -ip_get_variable2(self, varname_arg, index_arg, flag_arg) +ip_get_variable(self, varname, flag) VALUE self; - VALUE varname_arg; - VALUE index_arg; - VALUE flag_arg; + VALUE varname; + VALUE flag; { - struct tcltkip *ptr = get_ip(self); + VALUE *argv; + VALUE retval; + + argv = ALLOC_N(VALUE, 2); + StringValue(varname); + argv[0] = varname; + argv[1] = flag; + + retval = tk_funcall(ip_get_variable_core, 2, argv, self); + + free(argv); + + return retval; +} + +static VALUE +ip_get_variable2_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; +{ + struct tcltkip *ptr = get_ip(interp); int thr_crit_bup; volatile VALUE varname, index, flag; - if (NIL_P(index_arg)) { - return ip_get_variable(self, varname_arg, flag_arg); - } - - varname = varname_arg; - index = index_arg; - flag = flag_arg; + varname = argv[0]; + index = argv[1]; + flag = argv[2]; + /* StringValue(varname); StringValue(index); + */ #if TCL_MAJOR_VERSION >= 8 { @@ -5451,7 +6281,12 @@ Tcl_IncrRefCount(idxobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(idxobj); @@ -5476,7 +6311,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } Tcl_IncrRefCount(ret); @@ -5516,7 +6351,12 @@ char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5536,7 +6376,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } strval = rb_tainted_str_new2(ret); @@ -5550,22 +6390,52 @@ } static VALUE -ip_set_variable(self, varname_arg, value_arg, flag_arg) +ip_get_variable2(self, varname, index, flag) VALUE self; - VALUE varname_arg; - VALUE value_arg; - VALUE flag_arg; + VALUE varname; + VALUE index; + VALUE flag; { - struct tcltkip *ptr = get_ip(self); + VALUE *argv; + VALUE retval; + + argv = ALLOC_N(VALUE, 3); + StringValue(varname); + argv[0] = varname; + + if (NIL_P(index)) { + argv[1] = flag; + retval = tk_funcall(ip_get_variable_core, 2, argv, self); + } else { + StringValue(index); + argv[1] = index; + argv[2] = flag; + retval = tk_funcall(ip_get_variable2_core, 3, argv, self); + } + + free(argv); + + return retval; +} + +static VALUE +ip_set_variable_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; +{ + struct tcltkip *ptr = get_ip(interp); int thr_crit_bup; volatile VALUE varname, value, flag; - varname = varname_arg; - value = value_arg; - flag = flag_arg; + varname = argv[0]; + value = argv[1]; + flag = argv[2]; + /* StringValue(varname); StringValue(value); + */ #if TCL_MAJOR_VERSION >= 8 { @@ -5613,7 +6483,12 @@ # endif /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(valobj); @@ -5639,7 +6514,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } Tcl_IncrRefCount(ret); @@ -5680,7 +6555,12 @@ CONST char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5691,7 +6571,7 @@ } if (ret == NULL) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); } strval = rb_tainted_str_new2(ret); @@ -5705,29 +6585,50 @@ } static VALUE -ip_set_variable2(self, varname_arg, index_arg, value_arg, flag_arg) +ip_set_variable(self, varname, value, flag) VALUE self; - VALUE varname_arg; - VALUE index_arg; - VALUE value_arg; - VALUE flag_arg; + VALUE varname; + VALUE value; + VALUE flag; { - struct tcltkip *ptr = get_ip(self); + VALUE *argv; + VALUE retval; + + StringValue(varname); + StringValue(value); + + argv = ALLOC_N(VALUE, 3); + argv[0] = varname; + argv[1] = value; + argv[2] = flag; + + retval = tk_funcall(ip_set_variable_core, 3, argv, self); + + free(argv); + + return retval; +} + +static VALUE +ip_set_variable2_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; +{ + struct tcltkip *ptr = get_ip(interp); int thr_crit_bup; volatile VALUE varname, index, value, flag; - if (NIL_P(index_arg)) { - return ip_set_variable(self, varname_arg, value_arg, flag_arg); - } - - varname = varname_arg; - index = index_arg; - value = value_arg; - flag = flag_arg; + varname = argv[0]; + index = argv[1]; + value = argv[2]; + flag = argv[3]; + /* StringValue(varname); StringValue(index); StringValue(value); + */ #if TCL_MAJOR_VERSION >= 8 { @@ -5777,7 +6678,12 @@ Tcl_IncrRefCount(valobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(idxobj); @@ -5805,7 +6711,7 @@ /* Tcl_Release(ptr->ip); */ rbtk_release_ip(ptr); rb_thread_critical = thr_crit_bup; - rb_exc_raise(exc); + return exc; } Tcl_IncrRefCount(ret); @@ -5838,7 +6744,12 @@ CONST char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5850,7 +6761,7 @@ } if (ret == (char*)NULL) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); } Tcl_IncrRefCount(ret); @@ -5868,21 +6779,62 @@ } static VALUE -ip_unset_variable(self, varname_arg, flag_arg) +ip_set_variable2(self, varname, index, value, flag) VALUE self; - VALUE varname_arg; - VALUE flag_arg; + VALUE varname; + VALUE index; + VALUE value; + VALUE flag; { - struct tcltkip *ptr = get_ip(self); - volatile VALUE varname, value, flag; + VALUE *argv; + VALUE retval; - varname = varname_arg; - flag = flag_arg; + argv = ALLOC_N(VALUE, 4); + StringValue(varname); + argv[0] = varname; + if (NIL_P(index)) { + StringValue(value); + argv[1] = value; + argv[2] = flag; + retval = tk_funcall(ip_set_variable_core, 3, argv, self); + } else { + StringValue(index); + StringValue(value); + argv[1] = index; + argv[2] = value; + argv[3] = flag; + retval = tk_funcall(ip_set_variable2_core, 4, argv, self); + } + + free(argv); + + return retval; +} + +static VALUE +ip_unset_variable_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; +{ + struct tcltkip *ptr = get_ip(interp); + volatile VALUE varname, flag; + + varname = argv[0]; + flag = argv[1]; + + /* StringValue(varname); + */ /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return Qtrue; } @@ -5892,9 +6844,9 @@ if (ptr->return_value == TCL_ERROR) { if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { #if TCL_MAJOR_VERSION >= 8 - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); + return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); #else /* TCL_MAJOR_VERSION < 8 */ - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); #endif } return Qfalse; @@ -5903,28 +6855,51 @@ } static VALUE -ip_unset_variable2(self, varname_arg, index_arg, flag_arg) +ip_unset_variable(self, varname, flag) VALUE self; - VALUE varname_arg; - VALUE index_arg; - VALUE flag_arg; + VALUE varname; + VALUE flag; { - struct tcltkip *ptr = get_ip(self); - volatile VALUE varname, index, value, flag; + VALUE *argv; + VALUE retval; - if (NIL_P(index_arg)) { - return ip_unset_variable(self, varname_arg, flag_arg); - } + argv = ALLOC_N(VALUE, 2); + StringValue(varname); + argv[0] = varname; + argv[1] = flag; + + retval = tk_funcall(ip_unset_variable_core, 2, argv, self); - varname = varname_arg; - index = index_arg; - flag = flag_arg; + free(argv); + + return retval; +} +static VALUE +ip_unset_variable2_core(interp, argc, argv) + VALUE interp; + int argc; + VALUE *argv; +{ + struct tcltkip *ptr = get_ip(interp); + volatile VALUE varname, index, flag; + + varname = argv[0]; + index = argv[1]; + flag = argv[2]; + + /* StringValue(varname); StringValue(index); + */ /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) { + if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL + || Tcl_InterpDeleted(ptr->ip) +#if TCL_NAMESPACE_DEBUG + || rbtk_invalid_namespace(ptr) +#endif + ) { DUMP1("ip is deleted"); return Qtrue; } @@ -5934,9 +6909,9 @@ if (ptr->return_value == TCL_ERROR) { if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { #if TCL_MAJOR_VERSION >= 8 - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); + return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); #else /* TCL_MAJOR_VERSION < 8 */ - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); #endif } return Qfalse; @@ -5945,6 +6920,35 @@ } static VALUE +ip_unset_variable2(self, varname, index, flag) + VALUE self; + VALUE varname; + VALUE index; + VALUE flag; +{ + VALUE *argv; + VALUE retval; + + argv = ALLOC_N(VALUE, 3); + StringValue(varname); + argv[0] = varname; + + if (NIL_P(index)) { + argv[1] = flag; + retval = tk_funcall(ip_unset_variable_core, 2, argv, self); + } else { + StringValue(index); + argv[1] = index; + argv[2] = flag; + retval = tk_funcall(ip_unset_variable2_core, 3, argv, self); + } + + free(argv); + + return retval; +} + +static VALUE ip_get_global_var(self, varname) VALUE self; VALUE varname; @@ -6019,6 +7023,8 @@ if (NIL_P(ip_obj)) { interp = (Tcl_Interp *)NULL; + } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { + interp = (Tcl_Interp *)NULL; } else { interp = get_ip(ip_obj)->ip; } @@ -6403,6 +7409,8 @@ rb_global_variable(&eventloop_thread); rb_global_variable(&watchdog_thread); + rb_global_variable(&rbtk_pending_exception); + /* --------------------------------------------------------------- */ rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info()); @@ -6569,6 +7577,8 @@ eventloop_thread = 0; watchdog_thread = 0; + + rbtk_pending_exception = 0; /* --------------------------------------------------------------- */ Index: lib/multi-tk.rb =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/lib/multi-tk.rb,v retrieving revision 1.38 diff -u -r1.38 multi-tk.rb --- lib/multi-tk.rb 31 Jan 2005 04:14:50 -0000 1.38 +++ lib/multi-tk.rb 9 Feb 2005 08:53:11 -0000 @@ -411,7 +411,8 @@ def _receiver_mainloop(check_root) Thread.new{ while !@interp.deleted? - break if @interp._invoke_without_enc('info', 'command', '.').size == 0 + inf = @interp._invoke_without_enc('info', 'command', '.') + break if !inf.kind_of?(String) || inf != '.' sleep 0.5 end } @@ -970,9 +971,11 @@ ###################################### def _default_delete_hook(slave) - if @slave_ip_top[slave].kind_of?(String) + @slave_ip_tbl.delete(slave) + top = @slave_ip_top.delete(slave) + if top.kind_of?(String) # call default hook of safetk.tcl (ignore exceptions) - if @slave_ip_top[slave] == '' + if top == '' begin @interp._eval("::safe::disallowTk #{slave}") rescue @@ -980,20 +983,19 @@ end else # toplevel path begin - @interp._eval("::safe::tkDelete {} #{@slave_ip_top[slave]} #{slave}") + @interp._eval("::safe::tkDelete {} #{top} #{slave}") rescue warn("Waring: fail to call '::safe::tkDelete'") if $DEBUG begin - @interp._eval("destroy #{@slave_ip_top[slave]}") + @interp._eval("destroy #{top}") rescue warn("Waring: fail to destroy toplevel") if $DEBUG end end end end - @slave_ip_tbl.delete(slave) - @slave_ip_top.delete(slave) end + end @@ -1739,7 +1741,7 @@ # depend on TclTkIp class MultiTkIp - def mainloop(check_root = true, restart_on_dead = false) + def mainloop(check_root = true, restart_on_dead = true) #return self if self.slave? #return self if self != @@DEFAULT_MASTER if self != @@DEFAULT_MASTER @@ -1752,7 +1754,11 @@ rescue MultiTkIp_OK => ret # return value @wait_on_mainloop[1] = false - return ret.value.value + if ret.value.kind_of?(Thread) + return ret.value.value + else + return ret.value + end rescue SystemExit # exit IP warn("Warning: " + $! + " on " + self.inspect) if $DEBUG @@ -1762,7 +1768,7 @@ rescue Exception end self.delete - rescue Exception => e + rescue StandardError => e if $DEBUG warn("Warning: " + e.class.inspect + ((e.message.length > 0)? ' "' + e.message + '"': '') + @@ -1779,31 +1785,47 @@ unless restart_on_dead @wait_on_mainloop[1] = true +=begin + begin + @interp.mainloop(check_root) + rescue StandardError => e + if $DEBUG + warn("Warning: " + e.class.inspect + + ((e.message.length > 0)? ' "' + e.message + '"': '') + + " on " + self.inspect) + end + end +=end @interp.mainloop(check_root) @wait_on_mainloop[1] = false else - begin + loop do @wait_on_mainloop[1] = true - loop do - break unless self.alive? - if check_root - begin - break if TclTkLib.num_of_mainwindows == 0 - rescue Exception - break - end + break unless self.alive? + if check_root + begin + break if TclTkLib.num_of_mainwindows == 0 + rescue StandardError + break end - @interp.mainloop(check_root) end - #rescue StandardError - rescue Exception - if TclTkLib.mainloop_abort_on_exception != nil - STDERR.print("Warning: Tk mainloop receives ", $!.class.inspect, - " exception (ignore) : ", $!.message, "\n"); + break if @interp.deleted? + begin + @interp.mainloop(check_root) + rescue StandardError + if TclTkLib.mainloop_abort_on_exception != nil + #STDERR.print("Warning: Tk mainloop receives ", $!.class.inspect, + # " exception (ignore) : ", $!.message, "\n"); + if $DEBUG + warn("Warning: Tk mainloop receives ", $!.class.inspect, + " exception (ignore) : ", $!.message, "\n"); + end + end + rescue Exception=>e + ensure + @wait_on_mainloop[1] = false + Thread.pass end - retry - ensure - @wait_on_mainloop[1] = false end end self @@ -1875,18 +1897,17 @@ @interp._eval_without_enc("foreach i {#{after_ids}} {after cancel $i}") rescue Exception end -=begin + begin @interp._invoke('destroy', '.') unless @interp.deleted? rescue Exception end -=end + if @safe_base && !@interp.deleted? # do 'exit' to call the delete_hook procedure @interp._eval_without_enc('exit') - else - @interp.delete unless @interp.deleted? end + @interp.delete self end Index: lib/tk.rb =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/lib/tk.rb,v retrieving revision 1.141 diff -u -r1.141 tk.rb --- lib/tk.rb 31 Jan 2005 04:14:50 -0000 1.141 +++ lib/tk.rb 9 Feb 2005 08:53:13 -0000 @@ -3940,7 +3940,7 @@ #Tk.freeze module Tk - RELEASE_DATE = '2005-01-28'.freeze + RELEASE_DATE = '2005-02-09'.freeze autoload :AUTO_PATH, 'tk/variable' autoload :TCL_PACKAGE_PATH, 'tk/variable' Index: lib/tk/clock.rb =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/clock.rb,v retrieving revision 1.3 diff -u -r1.3 clock.rb --- lib/tk/clock.rb 20 Dec 2004 05:10:59 -0000 1.3 +++ lib/tk/clock.rb 9 Feb 2005 08:53:13 -0000 @@ -10,8 +10,9 @@ end def self.clicks(ms=nil) + ms = ms.to_s if ms.kind_of?(Symbol) case ms - when nil + when nil, '' tk_call_without_enc('clock','clicks').to_i when /^mic/ tk_call_without_enc('clock','clicks','-microseconds').to_i Index: lib/tk/timer.rb =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/timer.rb,v retrieving revision 1.10 diff -u -r1.10 timer.rb --- lib/tk/timer.rb 16 Dec 2004 07:13:12 -0000 1.10 +++ lib/tk/timer.rb 9 Feb 2005 08:53:13 -0000 @@ -420,6 +420,7 @@ @wait_var.value = 0 tk_call 'after', 'cancel', @after_id if @after_id @after_id = nil + Tk_CBTBL.delete(@id) ;# for GC self end Index: lib/tk/variable.rb =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/variable.rb,v retrieving revision 1.10 diff -u -r1.10 variable.rb --- lib/tk/variable.rb 4 Nov 2004 06:03:53 -0000 1.10 +++ lib/tk/variable.rb 9 Feb 2005 08:53:13 -0000 @@ -306,6 +306,7 @@ } self.value elsif val.kind_of?(Array) +=begin INTERP._set_global_var(@id, '') val.each{|v| #INTERP._set_variable(@id, _toUTF8(_get_eval_string(v)), @@ -316,6 +317,8 @@ TclTkLib::VarAccessFlag::LIST_ELEMENT) } self.value +=end + _fromUTF8(INTERP._set_global_var(@id, array2tk_list(val))) else #_fromUTF8(INTERP._set_global_var(@id, _toUTF8(_get_eval_string(val)))) _fromUTF8(INTERP._set_global_var(@id, _get_eval_string(val, true))) @@ -554,6 +557,29 @@ raise ArgumentError, "Array is expected" end val + end + + def lappend(*elems) + tk_call('lappend', @id, *elems) + self + end + + def lindex(idx) + tk_call('lindex', self.value, idx) + end + alias lget lindex + + def lget_i(idx) + number(lget(idx)).to_i + end + + def lget_f(idx) + number(lget(idx)).to_f + end + + def lset(idx, val) + tk_call('lset', @id, idx, val) + self end def inspect -- 永井 秀利 （九工大 知能情報） nagai@ai.kyutech.ac.jp