summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
authornagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2014-10-13 17:32:17 +0000
committernagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2014-10-13 17:32:17 +0000
commit7ce520e90a2aa4fae492ecdd0cba5b4df92c9462 (patch)
tree8b95fa7d27ba6100a488f35bc045b53cee4eba62 /ext
parent450307e38315f81c10d959054c49d8baed522027 (diff)
* 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
Diffstat (limited to 'ext')
-rw-r--r--ext/tk/extconf.rb4
-rw-r--r--ext/tk/tcltklib.c48
2 files changed, 48 insertions, 4 deletions
diff --git a/ext/tk/extconf.rb b/ext/tk/extconf.rb
index 99a7367782..8e20e42ea1 100644
--- a/ext/tk/extconf.rb
+++ b/ext/tk/extconf.rb
@@ -9,10 +9,10 @@ TkLib_Config['search_versions'] =
# %w[8.9 8.8 8.7 8.6 8.5 8.4 8.3 8.2 8.1 8.0 7.6 4.2]
# %w[8.7 8.6 8.5 8.4 8.3 8.2 8.1 8.0]
# %w[8.7 8.6 8.5 8.4 8.0] # to shorten search steps
- %w[8.5 8.4] # At present, Tcl/Tk8.6 is not supported.
+ %w[8.5 8.4 8.6] # Tcl/Tk8.6 support is experimental.
TkLib_Config['unsupported_versions'] =
- %w[8.8 8.7 8.6] # At present, Tcl/Tk8.6 is not supported.
+ %w[8.8 8.7] # Tcl/Tk8.6 support is experimental.
TkLib_Config['major_nums'] = '87'
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())) {