1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
$NetBSD: patch-ext_tk_tcltklib.c,v 1.1 2014/12/14 14:00:17 taca Exp $
* Add tcl/tk 8.6 support.
--- ext/tk/tcltklib.c.orig 2014-02-10 11:45:14.000000000 +0000
+++ ext/tk/tcltklib.c
@@ -6012,7 +6012,12 @@ ip_rbNamespaceObjCmd(clientData, interp,
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);
@@ -6020,15 +6025,38 @@ ip_rbNamespaceObjCmd(clientData, interp,
}
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); */
+ ret = Tcl_EvalObjv(interp, objc, cp_objv, 0);
+
+ 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 */
@@ -6056,9 +6084,10 @@ ip_rbNamespaceObjCmd(clientData, interp,
#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
@@ -6068,6 +6097,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))) {
@@ -6084,6 +6115,11 @@ ip_wrap_namespace_command(interp)
orig_info.deleteProc);
}
+#else /* tcl8.6 or later */
+ Tcl_GlobalEval(interp, "rename namespace __orig_namespace_command__");
+
+#endif
+
Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
#endif
@@ -8448,15 +8484,28 @@ invoke_tcl_proc(arg)
#endif
{
struct invoke_info *inf = (struct invoke_info *)arg;
+
+#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION < 6
int i, len;
-#if TCL_MAJOR_VERSION >= 8
int argc = inf->objc;
char **argv = (char **)NULL;
#endif
+ DUMP1("call invoke_tcl_proc");
+
+#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 6)
+
+ /* eval */
+ inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, TCL_EVAL_DIRECT);
+ /* inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, 0); */
+
+#else /* Tcl/Tk 7.x, 8.0 -- 8.5 */
+
/* memory allocation for arguments of this command */
-#if TCL_MAJOR_VERSION >= 8
+#if TCL_MAJOR_VERSION == 8
+ /* Tcl/Tk 8.0 -- 8.5 */
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));
@@ -8470,11 +8519,14 @@ 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 TCL_MAJOR_VERSION == 8
+ /* Tcl/Tk 8.0 -- 8.5 */
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);
@@ -8482,7 +8534,9 @@ invoke_tcl_proc(arg)
else
#endif
{
-#if TCL_MAJOR_VERSION >= 8
+#if TCL_MAJOR_VERSION == 8
+ /* Tcl/Tk 8.0 -- 8.5 */
+ 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);
@@ -8505,6 +8559,9 @@ invoke_tcl_proc(arg)
#endif
}
+#endif /* Tcl/Tk 8.6 or later || Tcl 7.x, 8.0 -- 8.5 */
+
+ DUMP1("end of invoke_tcl_proc");
return Qnil;
}
@@ -8644,7 +8701,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())) {
|
