From: "H.Yamamoto" <ocean@...2.ccsnet.ne.jp>
Date: 2005-04-12T13:23:32+09:00
Subject: [ruby-dev:26029] Re: tnono dumps core

山本です。

>原因が分かりました．
>Tcl_GlobalEval が埋め込みスクリプトの部分を解析するために
>渡した文字列を加工しようとして SEGV を起こしていました．
>マニュアル読みが不十分でした．ごめんなさい．

そういえば、前回の調査の時、

http://www.geocities.co.jp/SiliconValley/4137/dir4/tapi25.html で

  現在では少し仕様が厳しくなり、 Tcl_Evalに渡すTclコマンドは
  書き込み可能なメモリ領域にないといけません。 

というのを見かけてたんですが、あの時はこれで直らなかったし、
http://tmml.sourceforge.net/doc/tcl/CEval.html#ARG-script にも
記述がなかったので忘れてました。(--;

>この部分以外で文字列を直接コードに書いている部分では
>埋め込みスクリプトを持っていたり複数のコマンドを含めていたりは
>しておらず，Eval しようとしている文字列の加工が
>必要なものではなかったため，問題が出ていませんでした．

しかし、やはりマニュアルに「書き込み可能でないといけない」とあるので、
常に書き込み可能なメモリを渡した方がいいのではないでしょうか。幸い、
速度に違いはないようですし。

# 一部 1.10 と比べて戻ってない部分があるのですが、これは問題ありませんか？

Index: tcltklib.c
===================================================================
RCS file: /src/ruby/ext/tk/tcltklib.c,v
retrieving revision 1.10
diff -u -w -b -p -r1.10 tcltklib.c
--- tcltklib.c	30 Mar 2005 08:44:15 -0000	1.10
+++ tcltklib.c	12 Apr 2005 04:10:59 -0000
@@ -4,7 +4,7 @@
  *              Oct. 24, 1997   Y. Matsumoto
  */
 
-#define TCLTKLIB_RELEASE_DATE "2005-03-30"
+#define TCLTKLIB_RELEASE_DATE "2005-04-12"
 
 #include "ruby.h"
 #include "rubysig.h"
@@ -114,6 +114,35 @@ static VALUE ip_invoke _((int, VALUE*, V
 
 static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
 
+/* safe Tcl_Eval and Tcl_GlobalEval */
+
+static int
+tcl_eval(interp, cmd)
+    Tcl_Interp *interp;
+    const char *cmd; /* don't have to be writable */
+{
+    char *buf = strdup(cmd);
+    const int ret = Tcl_Eval(interp, buf);
+    free(buf);
+    return ret;
+}
+
+#undef Tcl_Eval
+#define Tcl_Eval tcl_eval
+
+static int
+tcl_global_eval(interp, cmd)
+    Tcl_Interp *interp;
+    const char *cmd; /* don't have to be writable */
+{
+    char *buf = strdup(cmd);
+    const int ret = Tcl_GlobalEval(interp, buf);
+    free(buf);
+    return ret;
+}
+
+#undef Tcl_GlobalEval
+#define Tcl_GlobalEval tcl_global_eval
 
 /* from tkAppInit.c */
 
@@ -4365,7 +4394,7 @@ delete_slaves(ip)
                 ip_finalize(slave);
 
                 Tcl_DeleteInterp(slave);
-                Tcl_Release(slave);
+                /* Tcl_Release(slave); */
             }
         }
 
@@ -4407,15 +4436,20 @@ ip_finalize(ip)
     delete_slaves(ip);
 
     /* delete root widget */
+    DUMP1("check `destroy'");
+    if (Tcl_GetCommandInfo(ip, "destroy", &info)) {
+        DUMP1("call `destroy'");
     Tcl_GlobalEval(ip, "destroy .");
+    }
 
     /* call finalize-hook-proc */
+    DUMP1("check `finalize-hook-proc'");
     if (Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
         DUMP2("call finalize hook proc '%s'", finalize_hook_name);
         Tcl_GlobalEval(ip, finalize_hook_name);
     }
 
-    DUMP1("call cancel aftern scripts");
+    DUMP1("cancel after callbacks");
     Tcl_GlobalEval(ip, "foreach id [after info] {after cancel $id}");
 
     Tcl_Release(ip);