Ticket #1085: parrot-41587-tcltklib-diff.txt

File parrot-41587-tcltklib-diff.txt, 9.7 KB (added by vkon, 5 years ago)

the patch itself

Line 
1diff -bru parrot-41587-o/runtime/parrot/library/TclLibrary.pir parrot-41587/runtime/parrot/library/TclLibrary.pir
2--- parrot-41587-o/runtime/parrot/library/TclLibrary.pir        Fri Jul 24 18:59:39 2009
3+++ parrot-41587/runtime/parrot/library/TclLibrary.pir  Fri Oct  2 17:25:54 2009
4@@ -35,6 +35,11 @@
5 .const int TCL_BREAK    = 3
6 .const int TCL_CONTINUE = 4
7 
8+.const int TCL_GLOBAL_ONLY     = 1
9+.const int TCL_NAMESPACE_ONLY  = 2
10+.const int TCL_APPEND_VALUE    = 4
11+.const int TCL_LIST_ELEMENT    = 8
12+
13 # DEBUG
14 .const int debug_objresult = 1
15 
16@@ -77,6 +82,34 @@
17     .return(res)
18 .end
19 
20+# pure string eval, which evals and returns a string
21+.sub eval_str :method
22+    .param string str
23+
24+    .local string res, error
25+    .local pmc f_eval, f_getstringresult, f_resetresult
26+    f_resetresult = get_global '_tcl_resetresult'
27+    f_eval = get_global '_tcl_eval'
28+    f_getstringresult = get_global '_tcl_getstringresult'
29+
30+    .local pmc interp
31+    interp = getattribute self,'interp'
32+
33+    f_resetresult(interp)
34+
35+    .local int rc
36+    rc = f_eval(interp,str)
37+    # check if the result is TCL_OK(=0)
38+    if rc==TCL_OK goto eval_ok
39+    res = f_getstringresult(interp,0)
40+    error = "error during Tcl_Eval: " . res
41+    die error
42+
43+eval_ok:
44+    res = f_getstringresult(interp,0)
45+    .return(res)
46+.end
47+
48 # Constructor for the interpreter object.
49 # optional parameter - path to the tcl shared library.
50 .sub init :method :vtable
51@@ -225,6 +258,8 @@
52     set_global '_tcl_resetresult', func
53     func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
54     set_global '_tcl_evalex', func
55+    func = dlfunc libtcl, "Tcl_Eval", "ipt"
56+    set_global '_tcl_eval', func
57     func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
58     set_global '_tcl_getstringfromobj', func
59     func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
60@@ -235,6 +270,18 @@
61     set_global '_tcl_getobjresult', func
62     func = dlfunc libtcl, "Tcl_GetObjType", "it"
63     set_global '_tcl_getobjtype', func
64+    func = dlfunc libtcl, "Tcl_GetVar", "tpti"
65+    set_global '_tcl_getvar', func
66+    func = dlfunc libtcl, "Tcl_GetVar2", "tptti"
67+    set_global '_tcl_getvar2', func
68+    func = dlfunc libtcl, "Tcl_SetVar", "tptti"
69+    set_global '_tcl_setvar', func
70+    func = dlfunc libtcl, "Tcl_SetVar2", "tpttti"
71+    set_global '_tcl_setvar2', func
72+    func = dlfunc libtcl, "Tcl_UnsetVar", "tpti"
73+    set_global '_tcl_unsetvar', func
74+    func = dlfunc libtcl, "Tcl_UnsetVar2", "tptti"
75+    set_global '_tcl_unsetvar2', func
76 
77     '_init_tclobj'()
78 
79@@ -345,19 +392,246 @@
80     .return(str)
81 .end
82 
83+=item getvar (VARNAME, FLAGS)
84+
85+Returns the value of Tcl variable VARNAME. The optional argument FLAGS
86+behaves as in I<setvar>.
87+
88+=back
89+
90+=cut
91+
92+.sub getvar :method
93+    .param string var
94+    .param int flags :optional
95+    .param int has_flags :opt_flag
96+
97+    .local pmc f_getvar
98+    f_getvar = get_global '_tcl_getvar'
99+    .local pmc interp
100+    interp = getattribute self,'interp'
101+    .local int flags
102+
103+    .Unless(has_flags,{
104+        flags = 0
105+    })
106+
107+    .local string res
108+    res = f_getvar(interp,var,flags)
109+
110+    .return(res)
111+.end
112+
113+=item getvar2 (VARNAME1, VARNAME2, FLAGS)
114+
115+Returns the value of the element VARNAME1(VARNAME2) of a Tcl array.
116+The optional argument FLAGS behaves as in I<setvar>.
117+
118+=back
119+
120+=cut
121+
122+.sub getvar2 :method
123+    .param string name1
124+    .param string name2
125+    .param int flags :optional
126+    .param int has_flags :opt_flag
127+
128+    .local pmc f_getvar2
129+    f_getvar2 = get_global '_tcl_getvar2'
130+    .local pmc interp
131+    interp = getattribute self,'interp'
132+    .local int flags
133+
134+    .Unless(has_flags,{
135+        flags = 0
136+    })
137+
138+    .local string res
139+    res = f_getvar2(interp,name1,name2,flags)
140+
141+    .return(res)
142+.end
143+
144+=item setvar (VARNAME, VALUE, FLAGS)
145+
146+The FLAGS field is optional. Sets Tcl variable VARNAME in the
147+interpreter to VALUE. The FLAGS argument is the usual Tcl one and
148+can be a bitwise OR of the constants TCL_GLOBAL_ONLY,
149+TCL_LEAVE_ERR_MSG, TCL_APPEND_VALUE, TCL_LIST_ELEMENT.
150+
151+=back
152+
153+=cut
154+
155+.sub setvar :method
156+    .param string var
157+    .param string val
158+    .param int flags :optional
159+    .param int has_flags :opt_flag
160+
161+    .local pmc f_setvar
162+    f_setvar = get_global '_tcl_setvar'
163+    .local pmc interp
164+    interp = getattribute self,'interp'
165+    .local int flags
166+
167+    .Unless(has_flags,{
168+        flags = 0
169+    })
170+
171+    .local string res
172+    res = f_setvar(interp,var,val,flags)
173+
174+    .return(res)
175+.end
176+
177+=item setvar2 (VARNAME1, VARNAME2, VALUE, FLAGS)
178+
179+Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional
180+argument FLAGS behaves as in I<SetVar> above.
181+Semantically this is very much like Perl's hash element.
182+
183+=back
184+
185+=cut
186+
187+.sub setvar2 :method
188+    .param string name1
189+    .param string name2
190+    .param string val
191+    .param int flags :optional
192+    .param int has_flags :opt_flag
193+
194+    .local pmc f_setvar2
195+    f_setvar2 = get_global '_tcl_setvar2'
196+    .local pmc interp
197+    interp = getattribute self,'interp'
198+    .local int flags
199+
200+    .Unless(has_flags,{
201+        flags = 0
202+    })
203+
204+    .local string res
205+    res = f_setvar2(interp,name1,name2,val,flags)
206+
207+    .return(res)
208+.end
209+
210+=item unsetvar (VARNAME, FLAGS)
211+
212+Unsets Tcl variable VARNAME. The optional argument FLAGS
213+behaves as in I<setvar>.
214+
215+=back
216+
217+=cut
218+
219+.sub unsetvar :method
220+    .param string var
221+    .param int flags :optional
222+    .param int has_flags :opt_flag
223+
224+    .local pmc f_unsetvar
225+    f_unsetvar = get_global '_tcl_unsetvar'
226+    .local pmc interp
227+    interp = getattribute self,'interp'
228+    .local int flags
229+
230+    .Unless(has_flags,{
231+        flags = 0
232+    })
233+
234+    .local string res
235+    res = f_unsetvar(interp,var,flags)
236+
237+    .return(res)
238+.end
239+
240+=item UnsetVar2 (VARNAME1, VARNAME2, FLAGS)
241+
242+Unsets the element VARNAME1(VARNAME2) of a Tcl array.
243+The optional argument FLAGS behaves as in I<setvar>.
244+
245+=back
246+
247+=cut
248+
249+.sub unsetvar2 :method
250+    .param string name1
251+    .param string name2
252+    .param int flags :optional
253+    .param int has_flags :opt_flag
254+
255+    .local pmc f_unsetvar2
256+    f_unsetvar2 = get_global '_tcl_unsetvar2'
257+    .local pmc interp
258+    interp = getattribute self,'interp'
259+    .local int flags
260+
261+    .Unless(has_flags,{
262+        flags = 0
263+    })
264+
265+    .local string res
266+    res = f_unsetvar2(interp,name1,name2,flags)
267+
268+    .return(res)
269+.end
270+
271+=item MainLoop
272+
273+MainLoop method, which corresponds to Tcl/Tk Tk_MainLoop call
274+
275+=back
276+
277+=cut
278+
279 .sub MainLoop :method
280-    say "MainLoop"
281-    # TO BE FIXED
282-    self.'eval'(<<'EOS')
283-while {[winfo exists .]} {
284-    update
285-}
286-EOS
287-#    .local pmc libtcl, f_mainloop
288-#    libtcl = get_global '_libtcl'
289-#    f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v"
290-#    f_mainloop()
291-    say "MainLoop-e!"
292+    # essentially we want to do:
293+    #   .local pmc f_mainloop
294+    #   f_mainloop = dlfunc libtk, "Tk_MainLoop", "v"
295+    #   f_mainloop()
296+    # we do not have libtk variable, however.
297+    # providing iface with libtk is easy, but we can avoid this
298+    # Instead of calling Tk_MainLoop, which is located in libtk8.5.so
299+    # we do same loop as in Tcl::Tk module. So loading tk shared library
300+    # is done by tcl itself.
301+    .local string res
302+    .local pmc libtcl
303+    .local pmc f_dooneevent, f_eval, f_getstringresult
304+    libtcl = get_global '_libtcl'
305+    f_eval = get_global '_tcl_eval'
306+    f_getstringresult = get_global '_tcl_getstringresult'
307+    f_dooneevent = dlfunc libtcl, "Tcl_DoOneEvent", "ii"
308+    .local pmc interp
309+    interp = getattribute self,'interp'
310+
311+    # Loop until mainwindow exists (its path is '.')
312+    # below are 2 implementations how we get know that mainwindow no more avail
313+    #  1. eval "winfo exists ."
314+    #  2. use global variable, which will be destroyed upon exit
315+    # Now we prefer 2nd method.
316+    .IfElse(0==1,{
317+        .DoWhile({
318+            f_dooneevent(0)  # spin it
319+            # check if '.' window still exists
320+            f_eval(interp, 'winfo exists .')
321+            res = f_getstringresult(interp,0)
322+        },res=="1")
323+    },{
324+        .local pmc f_getvar
325+        f_getvar = get_global '_tcl_getvar'
326+        self.'setvar'("MainLoop_continuing","y",TCL_GLOBAL_ONLY)
327+        f_eval(interp,"trace add command . delete {unset MainLoop_continuing}")
328+        .DoWhile({
329+            f_dooneevent(0)  # spin it
330+            # check if flag variable "MainLoop_continuing" still exists
331+            res = f_getvar(interp,"MainLoop_continuing",TCL_GLOBAL_ONLY)
332+         },res=="y")
333+    })
334+
335 .end
336 
337 =item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
338diff -bru parrot-41587-o/t/library/tcl_lib.t parrot-41587/t/library/tcl_lib.t
339--- parrot-41587-o/t/library/tcl_lib.t  Fri Jul 24 19:07:00 2009
340+++ parrot-41587/t/library/tcl_lib.t    Fri Oct  2 17:34:59 2009
341@@ -39,6 +39,8 @@
342 
343     .local string res
344     .local int ires
345+
346+    # misc evals
347     res = tcl.'eval'("return {3+3}")
348     'is'(res, '3+3', 'return of a string')
349     # TODO res = tcl.'eval'("return [list a b foo bar]")
350@@ -47,6 +49,27 @@
351     res = tcl.'eval'("return [expr 1.0]")
352     'is'(res, '1.0', 'return of double')
353 
354+    # variable nethods: getvar, setvar2, unsetvar2, etc.
355+    tcl.'setvar'("foo", "ok")
356+    res = tcl.'eval_str'("set foo")
357+    'is'(res,"ok", "setvar ok")
358+    res = tcl.'eval_str'("return $foo")
359+    'is'(res,"ok", "setvar ok")
360+
361+    tcl.'eval_str'('set a(OK) ok; set a(five) 5')
362+    res = tcl.'getvar2'('a','OK')
363+    'is'(res,'ok','getvar2 ok')
364+    tcl.'setvar2'("foo", "bar", "ok")
365+    res = tcl.'getvar2'('foo','bar')
366+    'is'(res,'ok','setvar2 ok')
367+    res = tcl.'eval_str'("set bar(foo)")
368+    'is'(res,"ok", "setvar ok")
369+    res = tcl.'eval_str'("return $foo(bar)")
370+    'is'(res,"ok", "setvar ok")
371+
372+    # MORE TBD
373+
374+
375 skip_all:
376 
377 .end