1 | diff -bru parrot-41727-o/config/gen/call_list/misc.in parrot-41727/config/gen/call_list/misc.in |
---|
2 | --- parrot-41727-o/config/gen/call_list/misc.in Fri Jul 24 19:07:17 2009 |
---|
3 | +++ parrot-41727/config/gen/call_list/misc.in Sun Oct 11 00:13:46 2009 |
---|
4 | @@ -60,6 +60,12 @@ |
---|
5 | I JOSI |
---|
6 | P JOSII |
---|
7 | |
---|
8 | +# Added for TclLibrary |
---|
9 | +t p3 |
---|
10 | +i pp3p |
---|
11 | +i pp3 |
---|
12 | +i ppd |
---|
13 | + |
---|
14 | # libpast |
---|
15 | p Ji |
---|
16 | p Jipp |
---|
17 | diff -bru parrot-41727-o/runtime/parrot/library/TclLibrary.pir parrot-41727/runtime/parrot/library/TclLibrary.pir |
---|
18 | --- parrot-41727-o/runtime/parrot/library/TclLibrary.pir Fri Jul 24 18:59:39 2009 |
---|
19 | +++ parrot-41727/runtime/parrot/library/TclLibrary.pir Fri Oct 16 17:30:57 2009 |
---|
20 | @@ -10,16 +10,6 @@ |
---|
21 | |
---|
22 | This module implements Tcl/Tk interface for Parrot. |
---|
23 | |
---|
24 | -=head1 TODO |
---|
25 | - |
---|
26 | -=over 2 |
---|
27 | - |
---|
28 | -=item Tcl_GetStringFromObj - check its declaration and usage |
---|
29 | - |
---|
30 | - func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3" |
---|
31 | - |
---|
32 | -=back |
---|
33 | - |
---|
34 | =cut |
---|
35 | |
---|
36 | .include "hllmacros.pir" |
---|
37 | @@ -35,6 +25,11 @@ |
---|
38 | .const int TCL_BREAK = 3 |
---|
39 | .const int TCL_CONTINUE = 4 |
---|
40 | |
---|
41 | +.const int TCL_GLOBAL_ONLY = 1 |
---|
42 | +.const int TCL_NAMESPACE_ONLY = 2 |
---|
43 | +.const int TCL_APPEND_VALUE = 4 |
---|
44 | +.const int TCL_LIST_ELEMENT = 8 |
---|
45 | + |
---|
46 | # DEBUG |
---|
47 | .const int debug_objresult = 1 |
---|
48 | |
---|
49 | @@ -42,7 +37,8 @@ |
---|
50 | .sub eval :method |
---|
51 | .param string str |
---|
52 | |
---|
53 | - .local string res, error |
---|
54 | + .local string error, sres |
---|
55 | + .local pmc res |
---|
56 | .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult |
---|
57 | f_resetresult = get_global '_tcl_resetresult' |
---|
58 | f_evalex = get_global '_tcl_evalex' |
---|
59 | @@ -58,8 +54,8 @@ |
---|
60 | rc = f_evalex(interp,str,-1,0) # interp, string, length or -1, flags |
---|
61 | # check if the result is TCL_OK(=0) |
---|
62 | if rc==TCL_OK goto eval_ok |
---|
63 | - res = f_getstringresult(interp,0) |
---|
64 | - error = "error during Tcl_EvalEx: " . res |
---|
65 | + sres = f_getstringresult(interp,0) |
---|
66 | + error = "error during Tcl_EvalEx: " . sres |
---|
67 | die error |
---|
68 | |
---|
69 | eval_ok: |
---|
70 | @@ -72,11 +68,39 @@ |
---|
71 | assign obj, tcl_obj_decl # ... and use it |
---|
72 | res = _pmc_from_tclobj(interp,obj) |
---|
73 | },{ |
---|
74 | - res = f_getstringresult(interp,0) |
---|
75 | + sres = f_getstringresult(interp,0) |
---|
76 | }) |
---|
77 | .return(res) |
---|
78 | .end |
---|
79 | |
---|
80 | +# pure string eval, which evals and returns a string |
---|
81 | +.sub eval_str :method |
---|
82 | + .param string str |
---|
83 | + |
---|
84 | + .local string res, error |
---|
85 | + .local pmc f_eval, f_getstringresult, f_resetresult |
---|
86 | + f_resetresult = get_global '_tcl_resetresult' |
---|
87 | + f_eval = get_global '_tcl_eval' |
---|
88 | + f_getstringresult = get_global '_tcl_getstringresult' |
---|
89 | + |
---|
90 | + .local pmc interp |
---|
91 | + interp = getattribute self,'interp' |
---|
92 | + |
---|
93 | + f_resetresult(interp) |
---|
94 | + |
---|
95 | + .local int rc |
---|
96 | + rc = f_eval(interp,str) |
---|
97 | + # check if the result is TCL_OK(=0) |
---|
98 | + if rc==TCL_OK goto eval_ok |
---|
99 | + res = f_getstringresult(interp,0) |
---|
100 | + error = "error during Tcl_Eval: " . res |
---|
101 | + die error |
---|
102 | + |
---|
103 | +eval_ok: |
---|
104 | + res = f_getstringresult(interp,0) |
---|
105 | + .return(res) |
---|
106 | +.end |
---|
107 | + |
---|
108 | # Constructor for the interpreter object. |
---|
109 | # optional parameter - path to the tcl shared library. |
---|
110 | .sub init :method :vtable |
---|
111 | @@ -92,12 +116,11 @@ |
---|
112 | |
---|
113 | unless_null libtcl, libtcl_loaded |
---|
114 | |
---|
115 | - if has_libname goto with_libname |
---|
116 | - '_tcl_load_lib'() |
---|
117 | - goto with_libname_e |
---|
118 | -with_libname: |
---|
119 | + .IfElse(has_libname,{ |
---|
120 | '_tcl_load_lib'(libname) |
---|
121 | -with_libname_e: |
---|
122 | + },{ |
---|
123 | + '_tcl_load_lib'() |
---|
124 | + }) |
---|
125 | libtcl = get_global '_libtcl' |
---|
126 | |
---|
127 | libtcl_loaded: |
---|
128 | @@ -125,13 +148,11 @@ |
---|
129 | .local pmc tclclass |
---|
130 | tclclass = newclass ['TclLibrary'] |
---|
131 | addattribute tclclass, 'interp' |
---|
132 | - |
---|
133 | .end |
---|
134 | |
---|
135 | =item _init_tclobj |
---|
136 | |
---|
137 | - creates a helper for Tcl_Obj struct |
---|
138 | - # do the tcl.h adoptations |
---|
139 | |
---|
140 | =cut |
---|
141 | |
---|
142 | @@ -162,7 +183,7 @@ |
---|
143 | # } internalRep; |
---|
144 | # } Tcl_Obj; |
---|
145 | |
---|
146 | - .local pmc tcl_obj_struct, tcl_obj_decl |
---|
147 | + .local pmc tcl_obj_struct, tcl_obj_struct_d, tcl_obj_decl |
---|
148 | tcl_obj_decl = new 'ResizablePMCArray' |
---|
149 | push tcl_obj_decl, .DATATYPE_INT |
---|
150 | push tcl_obj_decl, 0 |
---|
151 | @@ -184,7 +205,13 @@ |
---|
152 | |
---|
153 | # union TBD |
---|
154 | tcl_obj_struct = new 'UnManagedStruct', tcl_obj_decl |
---|
155 | - set_global '_tcl_obj_decl', tcl_obj_decl # XXXXXXXXX <---------- |
---|
156 | + set_global '_tcl_obj_decl', tcl_obj_decl |
---|
157 | + |
---|
158 | + set tcl_obj_decl[12], .DATATYPE_DOUBLE |
---|
159 | + set tcl_obj_decl[13], 0 |
---|
160 | + |
---|
161 | + tcl_obj_struct_d = new 'UnManagedStruct', tcl_obj_decl |
---|
162 | + set_global '_tcl_obj_decl_d', tcl_obj_decl |
---|
163 | .end |
---|
164 | |
---|
165 | # find proper shared library and use it. |
---|
166 | @@ -225,16 +252,41 @@ |
---|
167 | set_global '_tcl_resetresult', func |
---|
168 | func = dlfunc libtcl, "Tcl_EvalEx", "iptii" |
---|
169 | set_global '_tcl_evalex', func |
---|
170 | - func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3" |
---|
171 | + func = dlfunc libtcl, "Tcl_Eval", "ipt" |
---|
172 | + set_global '_tcl_eval', func |
---|
173 | + func = dlfunc libtcl, "Tcl_GetStringFromObj", "tp3" |
---|
174 | set_global '_tcl_getstringfromobj', func |
---|
175 | + func = dlfunc libtcl, "Tcl_GetIntFromObj", "ipp3" |
---|
176 | + set_global '_tcl_getintfromobj', func |
---|
177 | + func = dlfunc libtcl, "Tcl_GetDoubleFromObj", "ippp" |
---|
178 | + set_global '_tcl_getdoublefromobj', func |
---|
179 | func = dlfunc libtcl, "Tcl_GetStringResult", "tp" |
---|
180 | set_global '_tcl_getstringresult', func |
---|
181 | - func = dlfunc libtcl, "Tcl_ListObjGetElements", "vippp" # should be "vip3p" |
---|
182 | - set_global '_tcl_listobjgetelements', func |
---|
183 | func = dlfunc libtcl, "Tcl_GetObjResult", "pp" |
---|
184 | set_global '_tcl_getobjresult', func |
---|
185 | func = dlfunc libtcl, "Tcl_GetObjType", "it" |
---|
186 | set_global '_tcl_getobjtype', func |
---|
187 | + func = dlfunc libtcl, "Tcl_GetVar", "tpti" |
---|
188 | + set_global '_tcl_getvar', func |
---|
189 | + func = dlfunc libtcl, "Tcl_GetVar2", "tptti" |
---|
190 | + set_global '_tcl_getvar2', func |
---|
191 | + func = dlfunc libtcl, "Tcl_SetVar", "tptti" |
---|
192 | + set_global '_tcl_setvar', func |
---|
193 | + func = dlfunc libtcl, "Tcl_SetVar2", "tpttti" |
---|
194 | + set_global '_tcl_setvar2', func |
---|
195 | + func = dlfunc libtcl, "Tcl_UnsetVar", "tpti" |
---|
196 | + set_global '_tcl_unsetvar', func |
---|
197 | + func = dlfunc libtcl, "Tcl_UnsetVar2", "tptti" |
---|
198 | + set_global '_tcl_unsetvar2', func |
---|
199 | + |
---|
200 | + # for TclLibrary List |
---|
201 | + # need: Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjGetElements |
---|
202 | + func = dlfunc libtcl, "Tcl_ListObjLength", "ipp3" |
---|
203 | + set_global '_tcl_listobjlength', func |
---|
204 | + func = dlfunc libtcl, "Tcl_ListObjIndex", "ippip" |
---|
205 | + set_global '_tcl_listobjindex', func |
---|
206 | + func = dlfunc libtcl, "Tcl_ListObjGetElements", "ipp3p" |
---|
207 | + set_global '_tcl_listobjgetelements', func |
---|
208 | |
---|
209 | '_init_tclobj'() |
---|
210 | |
---|
211 | @@ -254,7 +306,8 @@ |
---|
212 | .param pmc tclobj |
---|
213 | |
---|
214 | # check what type this tcl obj is |
---|
215 | - say "enter pmc_from_tclobj" |
---|
216 | + |
---|
217 | + .local int rc |
---|
218 | |
---|
219 | # check what tclobj actually is (null, integer, list, etc) |
---|
220 | |
---|
221 | @@ -292,50 +345,81 @@ |
---|
222 | |
---|
223 | obj_type = tclobj[3] |
---|
224 | |
---|
225 | + #print "TCL obj_type is " |
---|
226 | + #say obj_type |
---|
227 | + |
---|
228 | if obj_type==0 goto EOJ # if obj_type is null, there's no internal rep |
---|
229 | |
---|
230 | if obj_type!=tclBooleanTypePtr goto m00 |
---|
231 | say "implement tclBooleanTypePtr!" |
---|
232 | goto EOJ |
---|
233 | + |
---|
234 | m00: |
---|
235 | if obj_type!=tclByteArrayTypePtr goto m01 |
---|
236 | say "implement tclByteArrayTypePtr" |
---|
237 | goto EOJ |
---|
238 | + |
---|
239 | m01: |
---|
240 | if obj_type!=tclDoubleTypePtr goto m02 |
---|
241 | #sv = newSViv(objPtr->internalRep.doubleValue); |
---|
242 | + # the code below doesn't currently work, so go to fallback |
---|
243 | + # (fix it!) |
---|
244 | say "implement tclDoubleTypePtr" |
---|
245 | goto EOJ |
---|
246 | + |
---|
247 | + .local pmc f_getdoublefromobj |
---|
248 | + .local pmc dres |
---|
249 | + f_getdoublefromobj = get_global '_tcl_getdoublefromobj' |
---|
250 | + dres = new 'Float' |
---|
251 | + rc = f_getdoublefromobj(interp, tclobj, dres) |
---|
252 | + say dres |
---|
253 | + #.local pmc tcl_obj_decl_d |
---|
254 | + #tcl_obj_decl_d = get_global '_tcl_obj_decl_d' # retrieve tcl_obj_d structure |
---|
255 | + #assign tclobj, tcl_obj_decl_d # ... and use it |
---|
256 | + #say "hujd1" |
---|
257 | + #dres = tclobj[4] |
---|
258 | + print "dres=" |
---|
259 | + say dres |
---|
260 | + .return(dres) |
---|
261 | + |
---|
262 | m02: |
---|
263 | if obj_type!=tclIntTypePtr goto m03 |
---|
264 | #sv = newSViv(objPtr->internalRep.longValue); |
---|
265 | - .local int ires |
---|
266 | - ires = tclobj[4] |
---|
267 | - say ires |
---|
268 | - .return(ires) |
---|
269 | + .local pmc f_getintfromobj |
---|
270 | + .local pmc iint |
---|
271 | + f_getintfromobj = get_global '_tcl_getintfromobj' |
---|
272 | + # "direct" way: |
---|
273 | + #.local int ires |
---|
274 | + #ires = tclobj[4] |
---|
275 | + # "better" way: |
---|
276 | + iint = new 'Integer' |
---|
277 | + rc = f_getintfromobj(interp, tclobj, iint) |
---|
278 | + .return(iint) |
---|
279 | + |
---|
280 | m03: |
---|
281 | if obj_type!=tclListTypePtr goto m04 |
---|
282 | |
---|
283 | - .local int objc |
---|
284 | - .local pmc objv # pointer which will hold array of tcl_obj's |
---|
285 | - |
---|
286 | - # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); |
---|
287 | - # if (objc) { .... } |
---|
288 | - .local pmc f_listobjgetelements |
---|
289 | - f_listobjgetelements = get_global '_tcl_listobjgetelements' |
---|
290 | - #f_listobjgetelements.(0, tclobj, objc, objv) |
---|
291 | - |
---|
292 | - say "implement tclListTypePtr" |
---|
293 | + .local pmc argh |
---|
294 | + argh = new 'Hash' |
---|
295 | + set argh['list'], tclobj |
---|
296 | + .local pmc tlist |
---|
297 | + tlist = new ['TclLibrary';'List'], argh |
---|
298 | goto EOJ |
---|
299 | + .return(tlist) |
---|
300 | + |
---|
301 | m04: |
---|
302 | if obj_type!=tclStringTypePtr goto m05 |
---|
303 | say "implement tclStringTypePtr" |
---|
304 | goto EOJ |
---|
305 | + |
---|
306 | m05: |
---|
307 | print "implement TCL obj_type " |
---|
308 | say obj_type |
---|
309 | |
---|
310 | EOJ: |
---|
311 | + # this is a fallback - |
---|
312 | + # if we do not have support for the type, we use |
---|
313 | + # "_tcl_getstringfromobj", which is universal but we like to avoid |
---|
314 | |
---|
315 | .local string str |
---|
316 | .local pmc f_getstr |
---|
317 | @@ -345,19 +429,246 @@ |
---|
318 | .return(str) |
---|
319 | .end |
---|
320 | |
---|
321 | +=item getvar (VARNAME, FLAGS) |
---|
322 | + |
---|
323 | +Returns the value of Tcl variable VARNAME. The optional argument FLAGS |
---|
324 | +behaves as in I<setvar>. |
---|
325 | + |
---|
326 | +=back |
---|
327 | + |
---|
328 | +=cut |
---|
329 | + |
---|
330 | +.sub getvar :method |
---|
331 | + .param string var |
---|
332 | + .param int flags :optional |
---|
333 | + .param int has_flags :opt_flag |
---|
334 | + |
---|
335 | + .local pmc f_getvar |
---|
336 | + f_getvar = get_global '_tcl_getvar' |
---|
337 | + .local pmc interp |
---|
338 | + interp = getattribute self,'interp' |
---|
339 | + .local int flags |
---|
340 | + |
---|
341 | + .Unless(has_flags,{ |
---|
342 | + flags = 0 |
---|
343 | + }) |
---|
344 | + |
---|
345 | + .local string res |
---|
346 | + res = f_getvar(interp,var,flags) |
---|
347 | + |
---|
348 | + .return(res) |
---|
349 | +.end |
---|
350 | + |
---|
351 | +=item getvar2 (VARNAME1, VARNAME2, FLAGS) |
---|
352 | + |
---|
353 | +Returns the value of the element VARNAME1(VARNAME2) of a Tcl array. |
---|
354 | +The optional argument FLAGS behaves as in I<setvar>. |
---|
355 | + |
---|
356 | +=back |
---|
357 | + |
---|
358 | +=cut |
---|
359 | + |
---|
360 | +.sub getvar2 :method |
---|
361 | + .param string name1 |
---|
362 | + .param string name2 |
---|
363 | + .param int flags :optional |
---|
364 | + .param int has_flags :opt_flag |
---|
365 | + |
---|
366 | + .local pmc f_getvar2 |
---|
367 | + f_getvar2 = get_global '_tcl_getvar2' |
---|
368 | + .local pmc interp |
---|
369 | + interp = getattribute self,'interp' |
---|
370 | + .local int flags |
---|
371 | + |
---|
372 | + .Unless(has_flags,{ |
---|
373 | + flags = 0 |
---|
374 | + }) |
---|
375 | + |
---|
376 | + .local string res |
---|
377 | + res = f_getvar2(interp,name1,name2,flags) |
---|
378 | + |
---|
379 | + .return(res) |
---|
380 | +.end |
---|
381 | + |
---|
382 | +=item setvar (VARNAME, VALUE, FLAGS) |
---|
383 | + |
---|
384 | +The FLAGS field is optional. Sets Tcl variable VARNAME in the |
---|
385 | +interpreter to VALUE. The FLAGS argument is the usual Tcl one and |
---|
386 | +can be a bitwise OR of the constants TCL_GLOBAL_ONLY, |
---|
387 | +TCL_LEAVE_ERR_MSG, TCL_APPEND_VALUE, TCL_LIST_ELEMENT. |
---|
388 | + |
---|
389 | +=back |
---|
390 | + |
---|
391 | +=cut |
---|
392 | + |
---|
393 | +.sub setvar :method |
---|
394 | + .param string var |
---|
395 | + .param string val |
---|
396 | + .param int flags :optional |
---|
397 | + .param int has_flags :opt_flag |
---|
398 | + |
---|
399 | + .local pmc f_setvar |
---|
400 | + f_setvar = get_global '_tcl_setvar' |
---|
401 | + .local pmc interp |
---|
402 | + interp = getattribute self,'interp' |
---|
403 | + .local int flags |
---|
404 | + |
---|
405 | + .Unless(has_flags,{ |
---|
406 | + flags = 0 |
---|
407 | + }) |
---|
408 | + |
---|
409 | + .local string res |
---|
410 | + res = f_setvar(interp,var,val,flags) |
---|
411 | + |
---|
412 | + .return(res) |
---|
413 | +.end |
---|
414 | + |
---|
415 | +=item setvar2 (VARNAME1, VARNAME2, VALUE, FLAGS) |
---|
416 | + |
---|
417 | +Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional |
---|
418 | +argument FLAGS behaves as in I<SetVar> above. |
---|
419 | +Semantically this is very much like Perl's hash element. |
---|
420 | + |
---|
421 | +=back |
---|
422 | + |
---|
423 | +=cut |
---|
424 | + |
---|
425 | +.sub setvar2 :method |
---|
426 | + .param string name1 |
---|
427 | + .param string name2 |
---|
428 | + .param string val |
---|
429 | + .param int flags :optional |
---|
430 | + .param int has_flags :opt_flag |
---|
431 | + |
---|
432 | + .local pmc f_setvar2 |
---|
433 | + f_setvar2 = get_global '_tcl_setvar2' |
---|
434 | + .local pmc interp |
---|
435 | + interp = getattribute self,'interp' |
---|
436 | + .local int flags |
---|
437 | + |
---|
438 | + .Unless(has_flags,{ |
---|
439 | + flags = 0 |
---|
440 | + }) |
---|
441 | + |
---|
442 | + .local string res |
---|
443 | + res = f_setvar2(interp,name1,name2,val,flags) |
---|
444 | + |
---|
445 | + .return(res) |
---|
446 | +.end |
---|
447 | + |
---|
448 | +=item unsetvar (VARNAME, FLAGS) |
---|
449 | + |
---|
450 | +Unsets Tcl variable VARNAME. The optional argument FLAGS |
---|
451 | +behaves as in I<setvar>. |
---|
452 | + |
---|
453 | +=back |
---|
454 | + |
---|
455 | +=cut |
---|
456 | + |
---|
457 | +.sub unsetvar :method |
---|
458 | + .param string var |
---|
459 | + .param int flags :optional |
---|
460 | + .param int has_flags :opt_flag |
---|
461 | + |
---|
462 | + .local pmc f_unsetvar |
---|
463 | + f_unsetvar = get_global '_tcl_unsetvar' |
---|
464 | + .local pmc interp |
---|
465 | + interp = getattribute self,'interp' |
---|
466 | + .local int flags |
---|
467 | + |
---|
468 | + .Unless(has_flags,{ |
---|
469 | + flags = 0 |
---|
470 | + }) |
---|
471 | + |
---|
472 | + .local string res |
---|
473 | + res = f_unsetvar(interp,var,flags) |
---|
474 | + |
---|
475 | + .return(res) |
---|
476 | +.end |
---|
477 | + |
---|
478 | +=item UnsetVar2 (VARNAME1, VARNAME2, FLAGS) |
---|
479 | + |
---|
480 | +Unsets the element VARNAME1(VARNAME2) of a Tcl array. |
---|
481 | +The optional argument FLAGS behaves as in I<setvar>. |
---|
482 | + |
---|
483 | +=back |
---|
484 | + |
---|
485 | +=cut |
---|
486 | + |
---|
487 | +.sub unsetvar2 :method |
---|
488 | + .param string name1 |
---|
489 | + .param string name2 |
---|
490 | + .param int flags :optional |
---|
491 | + .param int has_flags :opt_flag |
---|
492 | + |
---|
493 | + .local pmc f_unsetvar2 |
---|
494 | + f_unsetvar2 = get_global '_tcl_unsetvar2' |
---|
495 | + .local pmc interp |
---|
496 | + interp = getattribute self,'interp' |
---|
497 | + .local int flags |
---|
498 | + |
---|
499 | + .Unless(has_flags,{ |
---|
500 | + flags = 0 |
---|
501 | + }) |
---|
502 | + |
---|
503 | + .local string res |
---|
504 | + res = f_unsetvar2(interp,name1,name2,flags) |
---|
505 | + |
---|
506 | + .return(res) |
---|
507 | +.end |
---|
508 | + |
---|
509 | +=item MainLoop |
---|
510 | + |
---|
511 | +MainLoop method, which corresponds to Tcl/Tk Tk_MainLoop call |
---|
512 | + |
---|
513 | +=back |
---|
514 | + |
---|
515 | +=cut |
---|
516 | + |
---|
517 | .sub MainLoop :method |
---|
518 | - say "MainLoop" |
---|
519 | - # TO BE FIXED |
---|
520 | - self.'eval'(<<'EOS') |
---|
521 | -while {[winfo exists .]} { |
---|
522 | - update |
---|
523 | -} |
---|
524 | -EOS |
---|
525 | -# .local pmc libtcl, f_mainloop |
---|
526 | -# libtcl = get_global '_libtcl' |
---|
527 | -# f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v" |
---|
528 | -# f_mainloop() |
---|
529 | - say "MainLoop-e!" |
---|
530 | + # essentially we want to do: |
---|
531 | + # .local pmc f_mainloop |
---|
532 | + # f_mainloop = dlfunc libtk, "Tk_MainLoop", "v" |
---|
533 | + # f_mainloop() |
---|
534 | + # we do not have libtk variable, however. |
---|
535 | + # providing iface with libtk is easy, but we can avoid this |
---|
536 | + # Instead of calling Tk_MainLoop, which is located in libtk8.5.so |
---|
537 | + # we do same loop as in Tcl::Tk module. So loading tk shared library |
---|
538 | + # is done by tcl itself. |
---|
539 | + .local string res |
---|
540 | + .local pmc libtcl |
---|
541 | + .local pmc f_dooneevent, f_eval, f_getstringresult |
---|
542 | + libtcl = get_global '_libtcl' |
---|
543 | + f_eval = get_global '_tcl_eval' |
---|
544 | + f_getstringresult = get_global '_tcl_getstringresult' |
---|
545 | + f_dooneevent = dlfunc libtcl, "Tcl_DoOneEvent", "ii" |
---|
546 | + .local pmc interp |
---|
547 | + interp = getattribute self,'interp' |
---|
548 | + |
---|
549 | + # Loop until mainwindow exists (its path is '.') |
---|
550 | + # below are 2 implementations how we get know that mainwindow no more avail |
---|
551 | + # 1. eval "winfo exists ." |
---|
552 | + # 2. use global variable, which will be destroyed upon exit |
---|
553 | + # Now we prefer 2nd method. |
---|
554 | + .IfElse(0==1,{ |
---|
555 | + .DoWhile({ |
---|
556 | + f_dooneevent(0) # spin it |
---|
557 | + # check if '.' window still exists |
---|
558 | + f_eval(interp, 'winfo exists .') |
---|
559 | + res = f_getstringresult(interp,0) |
---|
560 | + },res=="1") |
---|
561 | + },{ |
---|
562 | + .local pmc f_getvar |
---|
563 | + f_getvar = get_global '_tcl_getvar' |
---|
564 | + self.'setvar'("MainLoop_continuing","y",TCL_GLOBAL_ONLY) |
---|
565 | + f_eval(interp,"trace add command . delete {unset MainLoop_continuing}") |
---|
566 | + .DoWhile({ |
---|
567 | + f_dooneevent(0) # spin it |
---|
568 | + # check if flag variable "MainLoop_continuing" still exists |
---|
569 | + res = f_getvar(interp,"MainLoop_continuing",TCL_GLOBAL_ONLY) |
---|
570 | + },res=="y") |
---|
571 | + }) |
---|
572 | + |
---|
573 | .end |
---|
574 | |
---|
575 | =item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list) |
---|
576 | @@ -403,6 +714,73 @@ |
---|
577 | die message |
---|
578 | .end |
---|
579 | |
---|
580 | +.namespace ['TclLibrary';'List'] |
---|
581 | + |
---|
582 | +=over 4 |
---|
583 | + |
---|
584 | +=item _init |
---|
585 | + |
---|
586 | +TclList support for Tcl/Tk library |
---|
587 | +Based on Tcl list object, i.e. TclObj of type tclListType |
---|
588 | + |
---|
589 | +=cut |
---|
590 | + |
---|
591 | +.sub _init :load :init |
---|
592 | + .local pmc tclclass |
---|
593 | + tclclass = newclass ['TclLibrary';'List'] |
---|
594 | + addattribute tclclass, 'list' |
---|
595 | +.end |
---|
596 | + |
---|
597 | +.sub init :method :vtable |
---|
598 | + .param pmc argh |
---|
599 | + |
---|
600 | + say "instantiating..." |
---|
601 | + #.local pmc tclobj |
---|
602 | + #tclobj = getattribute self, 'list' |
---|
603 | + say "yes, ['TclLibrary';'List'] obj created" |
---|
604 | +.end |
---|
605 | + |
---|
606 | +.sub length :method |
---|
607 | + .local int res |
---|
608 | + # TBD |
---|
609 | + .return(res) |
---|
610 | +.end |
---|
611 | + |
---|
612 | +.sub get_string :method |
---|
613 | + .local string res |
---|
614 | + # TBD |
---|
615 | + .return(res) |
---|
616 | +.end |
---|
617 | + |
---|
618 | +=comment |
---|
619 | + |
---|
620 | +efficient way to extract all elements at once: |
---|
621 | + .local pmc objc, objv # pointer which will hold array of tcl_obj's |
---|
622 | + .local pmc objc_ptr, objv_ptr |
---|
623 | + |
---|
624 | + objv = new 'String' |
---|
625 | + objv = "qwerty" |
---|
626 | + objv_ptr = new 'String' |
---|
627 | + objv_ptr = "qwerty" |
---|
628 | + objc = new 'Integer' |
---|
629 | + |
---|
630 | + # Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); |
---|
631 | + # if (objc) { .... } |
---|
632 | + |
---|
633 | + .local pmc f_listobjgetelements |
---|
634 | + f_listobjgetelements = get_global '_tcl_listobjgetelements' |
---|
635 | + rc = f_listobjgetelements(interp, tclobj, objc, objv_ptr) |
---|
636 | + # we have objc TclObj in objv_ptr |
---|
637 | + print "objc=" |
---|
638 | + say objc |
---|
639 | + print "rc=" |
---|
640 | + say rc |
---|
641 | + |
---|
642 | + TBD |
---|
643 | + |
---|
644 | +=cut |
---|
645 | + |
---|
646 | + |
---|
647 | =back |
---|
648 | |
---|
649 | |
---|
650 | diff -bru parrot-41727-o/t/library/tcl_lib.t parrot-41727/t/library/tcl_lib.t |
---|
651 | --- parrot-41727-o/t/library/tcl_lib.t Fri Jul 24 19:07:00 2009 |
---|
652 | +++ parrot-41727/t/library/tcl_lib.t Fri Oct 16 17:24:08 2009 |
---|
653 | @@ -31,7 +31,7 @@ |
---|
654 | load_bytecode 'TclLibrary.pbc' # TBD pbc |
---|
655 | 'ok'(1, 'loaded TclLibrary') |
---|
656 | |
---|
657 | - goto skip_all # this is TEMPORARY untill the case of missing libtcl is fixed |
---|
658 | + goto skip_all # this is TEMPORARY untill the hang with tcl84.dll/cygwin is fixed |
---|
659 | |
---|
660 | .local pmc tcl |
---|
661 | tcl = new 'TclLibrary' |
---|
662 | @@ -39,14 +39,47 @@ |
---|
663 | |
---|
664 | .local string res |
---|
665 | .local int ires |
---|
666 | + |
---|
667 | + # misc evals |
---|
668 | res = tcl.'eval'("return {3+3}") |
---|
669 | 'is'(res, '3+3', 'return of a string') |
---|
670 | + res = tcl.'eval'("string repeat {qwerty} 2") |
---|
671 | + 'is'(res, 'qwertyqwerty', 'test string') |
---|
672 | # TODO res = tcl.'eval'("return [list a b foo bar]") |
---|
673 | ires = tcl.'eval'("expr {3+3}") |
---|
674 | 'is'(ires, 6, 'return of an integer') |
---|
675 | res = tcl.'eval'("return [expr 1.0]") |
---|
676 | 'is'(res, '1.0', 'return of double') |
---|
677 | |
---|
678 | + # variable methods: getvar, setvar2, unsetvar2, etc. |
---|
679 | + tcl.'setvar'("foo", "ok") |
---|
680 | + res = tcl.'eval_str'("set foo") |
---|
681 | + 'is'(res,"ok", "setvar ok") |
---|
682 | + res = tcl.'eval_str'("return $foo") |
---|
683 | + 'is'(res,"ok", "setvar ok") |
---|
684 | + |
---|
685 | + goto skip2 |
---|
686 | + tcl.'eval_str'('set a(OK) ok; set a(five) 5') |
---|
687 | + res = tcl.'getvar2'('a','OK') |
---|
688 | + 'is'(res,'ok','getvar2 ok') |
---|
689 | + tcl.'setvar2'("foo", "bar", "ok") |
---|
690 | + res = tcl.'getvar2'('foo','bar') |
---|
691 | + 'is'(res,'ok','setvar2 ok') |
---|
692 | + res = tcl.'eval_str'("set bar(foo)") |
---|
693 | + 'is'(res,"ok", "setvar ok") |
---|
694 | + res = tcl.'eval_str'("return $foo(bar)") |
---|
695 | + 'is'(res,"ok", "setvar ok") |
---|
696 | + |
---|
697 | +skip2: |
---|
698 | + # list |
---|
699 | + .local pmc tlist |
---|
700 | + tlist = tcl.'eval'("return [list a b foo bar]") |
---|
701 | + ires = tlist.'length'() |
---|
702 | + ok(ires,4,"list length") |
---|
703 | + |
---|
704 | + # MORE TBD |
---|
705 | + |
---|
706 | + |
---|
707 | skip_all: |
---|
708 | |
---|
709 | .end |
---|