From: Hidetoshi NAGAI Date: 2005-01-27T18:37:56+09:00 Subject: [ruby-dev:25567] Re: some problems on ext/tk/sample/**/*.rb 永井@知能．九工大です． From: Hidetoshi NAGAI Subject: [ruby-dev:25556] Re: some problems on ext/tk/sample/**/*.rb Date: Thu, 27 Jan 2005 02:02:57 +0900 Message-ID: <20050127.020253.71101772.nagai@ai.kyutech.ac.jp> > 最後にもう一つだけ，Tcl_Eval を使わない方法を試してみたいと考えてます． > うんざりしているとは思いますが，あと一度，協力をお願いできないでしょうか． Tcl_Eval を使わない方法だと，逆に SEGV の可能性が 高くなってしまいました．(^_^; 仕方ないのでその代りに別のチェックを追加してみました． これでもダメなら本当にお手上げ (少なくとも現時点では) ですので， 問題となっている終了処理を bcc32 の場合だけ一切行わないように 修正することにします．(;_;) また，添付のパッチは From: nobu@ruby-lang.org Subject: [ruby-dev:25552] Re: merge tcltklib and tk Date: Thu, 27 Jan 2005 00:18:07 +0900 Message-ID: <200501261518.j0QFI3Pm013241@sharui.nakada.niregi.kanuma.tochigi.jp> > もう一点、cygwinで--with-tcltk-stubsを指定すると > Tcl_GetCurrentNamespace()が未定義でリンクできないようです。 についても対策を行っているつもりです． この件についても試してみて頂けると助かります． Index: tcltklib.c =================================================================== RCS file: /var/cvs/src/ruby/ext/tk/tcltklib.c,v retrieving revision 1.1 diff -u -r1.1 tcltklib.c --- tcltklib.c 25 Jan 2005 14:31:44 -0000 1.1 +++ tcltklib.c 27 Jan 2005 09:28:28 -0000 @@ -4,7 +4,7 @@ * Oct. 24, 1997 Y. Matsumoto */ -#define TCLTKLIB_RELEASE_DATE "2005-01-25" +#define TCLTKLIB_RELEASE_DATE "2005-01-27" #include "ruby.h" #include "rubysig.h" @@ -205,16 +205,32 @@ #endif static int ip_null_namespace _((Tcl_Interp *)); -#if TCL_MAJOR_VERSION >= 8 -#ifndef Tcl_GetCurrentNamespace + +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 +# ifndef Tcl_GetCurrentNamespace EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *)); -#endif +# endif +# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) +# ifndef Tcl_GetCurrentNamespace +#define FunctionNum_of_GetCurrentNamespace 124 +struct DummyTclIntStubs { + 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) +# endif +# endif #endif /*---- class TclTkIp ----*/ struct tcltkip { Tcl_Interp *ip; /* the interpreter */ + Tcl_Namespace *default_ns; /* default namespace */ 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 */ @@ -3333,18 +3349,19 @@ Tcl_Preserve(slave); - if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave)) { - if (Tcl_Eval(slave, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (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) && !ip_null_namespace(slave) && + Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(slave, finalize_hook_name); + } - if (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); } } @@ -3355,7 +3372,7 @@ del_root(slave); /* while(!rbtk_InterpDeleted(slave)) { */ if (!Tcl_InterpDeleted(slave)) { - DUMP1("wait ip is deleted"); + DUMP2("delete slave ip(%lx)", slave); Tcl_DeleteInterp(slave); } @@ -3376,6 +3393,7 @@ { Tcl_CmdInfo info; int thr_crit_bup; + char* argv[2]; DUMP2("free Tcl Interp %lx", ptr->ip); if (ptr) { @@ -3384,7 +3402,9 @@ DUMP2("IP ref_count = %d", ptr->ref_count); - if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip)) { + if (!Tcl_InterpDeleted(ptr->ip) && + !ip_null_namespace(ptr->ip) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns) { DUMP2("IP(%lx) is not deleted", ptr->ip); /* Tcl_Preserve(ptr->ip); */ rbtk_preserve_ip(ptr); @@ -3393,25 +3413,32 @@ Tcl_ResetResult(ptr->ip); - if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { + if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + 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) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { + if (!Tcl_InterpDeleted(ptr->ip) && + !ip_null_namespace(ptr->ip) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + 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_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { - DUMP2("call finalize hook proc '%s'", finalize_hook_name); - Tcl_Eval(ptr->ip, finalize_hook_name); - } - /* del_root(ptr->ip); */ DUMP1("delete interp"); /* while(!rbtk_InterpDeleted(ptr->ip)) { */ if (!Tcl_InterpDeleted(ptr->ip)) { - DUMP1("wait ip is deleted"); + DUMP2("delete ip(%lx)", ptr->ip); Tcl_DeleteInterp(ptr->ip); } @@ -3470,6 +3497,9 @@ rb_raise(rb_eRuntimeError, "fail to create a new Tk interpreter"); } + DUMP1("get current namespace"); + ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip); + rbtk_preserve_ip(ptr); DUMP2("IP ref_count = %d", ptr->ref_count); current_interp = ptr->ip; @@ -3711,6 +3741,7 @@ rb_thread_critical = thr_crit_bup; rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter"); } + slave->default_ns = Tcl_GetCurrentNamespace(slave->ip); rbtk_preserve_ip(slave); slave->has_orig_exit @@ -3878,25 +3909,31 @@ delete_slaves(ptr->ip); DUMP1("finalize operation"); - if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { - if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { + if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + 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) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { + if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip) && + Tcl_GetCurrentNamespace(ptr->ip) == ptr->default_ns && + 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_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { - DUMP2("call finalize hook proc '%s'", finalize_hook_name); - Tcl_Eval(ptr->ip, finalize_hook_name); - } - del_root(ptr->ip); DUMP1("delete interp"); /* while(!rbtk_InterpDeleted(ptr->ip)) { */ if (!Tcl_InterpDeleted(ptr->ip)) { - DUMP1("wait ip is deleted"); + DUMP2("delete ip(%lx)", ptr->ip); Tcl_DeleteInterp(ptr->ip); } @@ -3914,6 +3951,7 @@ #if TCL_MAJOR_VERSION < 8 return 0; #else /* support Namespace */ + DUMP2("current namespace %lx",Tcl_GetCurrentNamespace(interp)); return ( Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL ); #endif } @@ -4053,7 +4091,8 @@ Tcl_IncrRefCount(cmd); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); Tcl_DecrRefCount(cmd); rb_thread_critical = thr_crit_bup; @@ -4094,7 +4133,8 @@ DUMP2("Tcl_Eval(%s)", cmd_str); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); ptr->return_value = TCL_OK; return rb_tainted_str_new2(""); @@ -4299,7 +4339,8 @@ rb_secure(4); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); rb_raise(rb_eRuntimeError, "interpreter is deleted"); } @@ -4788,7 +4829,8 @@ ptr = get_ip(interp); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } @@ -5270,7 +5312,8 @@ Tcl_IncrRefCount(nameobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); rb_thread_critical = thr_crit_bup; @@ -5334,7 +5377,8 @@ char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5406,7 +5450,8 @@ Tcl_IncrRefCount(idxobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(idxobj); @@ -5471,7 +5516,8 @@ char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5568,7 +5614,8 @@ # endif /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(valobj); @@ -5635,7 +5682,8 @@ CONST char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5732,7 +5780,8 @@ Tcl_IncrRefCount(valobj); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); Tcl_DecrRefCount(nameobj); Tcl_DecrRefCount(idxobj); @@ -5793,7 +5842,8 @@ CONST char *ret; /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } else { @@ -5837,7 +5887,8 @@ StringValue(varname); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return Qtrue; } @@ -5879,7 +5930,8 @@ StringValue(index); /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip) + || Tcl_GetCurrentNamespace(ptr->ip) != ptr->default_ns) { DUMP1("ip is deleted"); return Qtrue; } -- 永井 秀利 （九工大 知能情報） nagai@ai.kyutech.ac.jp