From 7ce520e90a2aa4fae492ecdd0cba5b4df92c9462 Mon Sep 17 00:00:00 2001
From: nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>
Date: Mon, 13 Oct 2014 17:32:17 +0000
Subject: * ext/tk/tcltklib.c: (experimental) support Tcl/Tk8.6.2. *
 ext/tk/extconf.rb: ditto.

git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@47908 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
---
 ext/tk/tcltklib.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 46 insertions(+), 2 deletions(-)

(limited to 'ext/tk/tcltklib.c')

diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c
index 5bd532998f..1ec4cec52e 100644
--- a/ext/tk/tcltklib.c
+++ b/ext/tk/tcltklib.c
@@ -6022,7 +6022,12 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
     Tcl_CmdInfo info;
     int ret;
 
+    DUMP1("call ip_rbNamespaceObjCmd");
+    DUMP2("objc = %d", objc);
+    DUMP2("objv[0] = '%s'", Tcl_GetString(objv[0]));
+    DUMP2("objv[1] = '%s'", Tcl_GetString(objv[1]));
     if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) {
+      DUMP1("fail to get __orig_namespace_command__");
         Tcl_ResetResult(interp);
         Tcl_AppendResult(interp,
                          "invalid command name \"namespace\"", (char*)NULL);
@@ -6030,15 +6035,37 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
     }
 
     rbtk_eventloop_depth++;
-    /* DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); */
+    DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth);
 
     if (info.isNativeObjectProc) {
+#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
+        DUMP1("call a native-object-proc");
         ret = (*(info.objProc))(info.objClientData, interp, objc, objv);
+#else
+        /* Tcl8.6 or later */
+        int i;
+        Tcl_Obj **cp_objv;
+        char org_ns_cmd_name[] = "__orig_namespace_command__";
+
+        DUMP1("call a native-object-proc for tcl8.6 or later");
+        cp_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc + 1));
+
+        cp_objv[0] = Tcl_NewStringObj(org_ns_cmd_name, strlen(org_ns_cmd_name));
+        for(i = 1; i < objc; i++) {
+            cp_objv[i] = objv[i];
+        }
+        cp_objv[objc] = (Tcl_Obj *)NULL;
+
+        ret = Tcl_EvalObjv(interp, objc, cp_objv, TCL_EVAL_DIRECT);
+
+        ckfree((char*)cp_objv);
+#endif
     } else {
         /* string interface */
         int i;
         char **argv;
 
+        DUMP1("call with the string-interface");
         /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */
         argv = RbTk_ALLOC_N(char *, (objc + 1));
 #if 0 /* use Tcl_Preserve/Release */
@@ -6066,9 +6093,10 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
 #endif
     }
 
-    /* DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); */
+    DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth);
     rbtk_eventloop_depth--;
 
+    DUMP1("end of ip_rbNamespaceObjCmd");
     return ret;
 }
 #endif
@@ -6078,6 +6106,8 @@ ip_wrap_namespace_command(interp)
     Tcl_Interp *interp;
 {
 #if TCL_MAJOR_VERSION >= 8
+
+#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
     Tcl_CmdInfo orig_info;
 
     if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) {
@@ -6094,6 +6124,11 @@ ip_wrap_namespace_command(interp)
                           orig_info.deleteProc);
     }
 
+#else /* tcl8.6 or later */
+    Tcl_Eval(interp, "rename namespace __orig_namespace_command__");
+
+#endif
+
     Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
                          (ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
 #endif
@@ -8464,9 +8499,12 @@ invoke_tcl_proc(arg)
     char **argv = (char **)NULL;
 #endif
 
+    DUMP1("call invoke_tcl_proc");
+
     /* memory allocation for arguments of this command */
 #if TCL_MAJOR_VERSION >= 8
     if (!inf->cmdinfo.isNativeObjectProc) {
+        DUMP1("called proc is not a native-obj-proc");
         /* string interface */
         /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */
         argv = RbTk_ALLOC_N(char *, (argc+1));
@@ -8480,11 +8518,13 @@ invoke_tcl_proc(arg)
     }
 #endif
 
+    DUMP1("reset result of tcl-interp");
     Tcl_ResetResult(inf->ptr->ip);
 
     /* Invoke the C procedure */
 #if TCL_MAJOR_VERSION >= 8
     if (inf->cmdinfo.isNativeObjectProc) {
+        DUMP1("call tcl_proc as a native-obj-proc");
         inf->ptr->return_value
             = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData,
                                         inf->ptr->ip, inf->objc, inf->objv);
@@ -8493,6 +8533,7 @@ invoke_tcl_proc(arg)
 #endif
     {
 #if TCL_MAJOR_VERSION >= 8
+        DUMP1("call tcl_proc as not a native-obj-proc");
         inf->ptr->return_value
             = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
                                      argc, (CONST84 char **)argv);
@@ -8515,6 +8556,7 @@ invoke_tcl_proc(arg)
 #endif
     }
 
+    DUMP1("end of invoke_tcl_proc");
     return Qnil;
 }
 
@@ -8654,7 +8696,9 @@ ip_invoke_core(interp, argc, argv)
 #endif
 
     /* invoke tcl-proc */
+    DUMP1("invoke tcl-proc");
     rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
+    DUMP2("status of tcl-proc, %d", status);
     switch(status) {
     case TAG_RAISE:
         if (NIL_P(rb_errinfo())) {
-- 
cgit v1.2.3