永井@知能.九工大です.

From: Hidetoshi NAGAI <nagai / ai.kyutech.ac.jp>
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