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

diff -bru parrot-41587-o/runtime/parrot/library/TclLibrary.pir parrot-41587/runtime/parrot/library/TclLibrary.pir
--- parrot-41587-o/runtime/parrot/library/TclLibrary.pir        Fri Jul 24 18:59:39 2009
+++ parrot-41587/runtime/parrot/library/TclLibrary.pir  Fri Oct  2 17:25:54 2009
@@ -35,6 +35,11 @@
 .const int TCL_BREAK    = 3
 .const int TCL_CONTINUE = 4
 
+.const int TCL_GLOBAL_ONLY     = 1
+.const int TCL_NAMESPACE_ONLY  = 2
+.const int TCL_APPEND_VALUE    = 4
+.const int TCL_LIST_ELEMENT    = 8
+
 # DEBUG
 .const int debug_objresult = 1
 
@@ -77,6 +82,34 @@
     .return(res)
 .end
 
+# pure string eval, which evals and returns a string
+.sub eval_str :method
+    .param string str
+
+    .local string res, error
+    .local pmc f_eval, f_getstringresult, f_resetresult
+    f_resetresult = get_global '_tcl_resetresult'
+    f_eval = get_global '_tcl_eval'
+    f_getstringresult = get_global '_tcl_getstringresult'
+
+    .local pmc interp
+    interp = getattribute self,'interp'
+
+    f_resetresult(interp)
+
+    .local int rc
+    rc = f_eval(interp,str)
+    # check if the result is TCL_OK(=0)
+    if rc==TCL_OK goto eval_ok
+    res = f_getstringresult(interp,0)
+    error = "error during Tcl_Eval: " . res
+    die error
+
+eval_ok:
+    res = f_getstringresult(interp,0)
+    .return(res)
+.end
+
 # Constructor for the interpreter object.
 # optional parameter - path to the tcl shared library.
 .sub init :method :vtable
@@ -225,6 +258,8 @@
     set_global '_tcl_resetresult', func
     func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
     set_global '_tcl_evalex', func
+    func = dlfunc libtcl, "Tcl_Eval", "ipt"
+    set_global '_tcl_eval', func
     func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
     set_global '_tcl_getstringfromobj', func
     func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
@@ -235,6 +270,18 @@
     set_global '_tcl_getobjresult', func
     func = dlfunc libtcl, "Tcl_GetObjType", "it"
     set_global '_tcl_getobjtype', func
+    func = dlfunc libtcl, "Tcl_GetVar", "tpti"
+    set_global '_tcl_getvar', func
+    func = dlfunc libtcl, "Tcl_GetVar2", "tptti"
+    set_global '_tcl_getvar2', func
+    func = dlfunc libtcl, "Tcl_SetVar", "tptti"
+    set_global '_tcl_setvar', func
+    func = dlfunc libtcl, "Tcl_SetVar2", "tpttti"
+    set_global '_tcl_setvar2', func
+    func = dlfunc libtcl, "Tcl_UnsetVar", "tpti"
+    set_global '_tcl_unsetvar', func
+    func = dlfunc libtcl, "Tcl_UnsetVar2", "tptti"
+    set_global '_tcl_unsetvar2', func
 
     '_init_tclobj'()
 
@@ -345,19 +392,246 @@
     .return(str)
 .end
 
+=item getvar (VARNAME, FLAGS)
+
+Returns the value of Tcl variable VARNAME. The optional argument FLAGS
+behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub getvar :method
+    .param string var
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_getvar
+    f_getvar = get_global '_tcl_getvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_getvar(interp,var,flags)
+
+    .return(res)
+.end
+
+=item getvar2 (VARNAME1, VARNAME2, FLAGS)
+
+Returns the value of the element VARNAME1(VARNAME2) of a Tcl array.
+The optional argument FLAGS behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub getvar2 :method
+    .param string name1
+    .param string name2
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_getvar2
+    f_getvar2 = get_global '_tcl_getvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_getvar2(interp,name1,name2,flags)
+
+    .return(res)
+.end
+
+=item setvar (VARNAME, VALUE, FLAGS)
+
+The FLAGS field is optional. Sets Tcl variable VARNAME in the
+interpreter to VALUE. The FLAGS argument is the usual Tcl one and
+can be a bitwise OR of the constants TCL_GLOBAL_ONLY,
+TCL_LEAVE_ERR_MSG, TCL_APPEND_VALUE, TCL_LIST_ELEMENT.
+
+=back
+
+=cut
+
+.sub setvar :method
+    .param string var
+    .param string val
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_setvar
+    f_setvar = get_global '_tcl_setvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_setvar(interp,var,val,flags)
+
+    .return(res)
+.end
+
+=item setvar2 (VARNAME1, VARNAME2, VALUE, FLAGS)
+
+Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional
+argument FLAGS behaves as in I<SetVar> above.
+Semantically this is very much like Perl's hash element.
+
+=back
+
+=cut
+
+.sub setvar2 :method
+    .param string name1
+    .param string name2
+    .param string val
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_setvar2
+    f_setvar2 = get_global '_tcl_setvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_setvar2(interp,name1,name2,val,flags)
+
+    .return(res)
+.end
+
+=item unsetvar (VARNAME, FLAGS)
+
+Unsets Tcl variable VARNAME. The optional argument FLAGS
+behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub unsetvar :method
+    .param string var
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_unsetvar
+    f_unsetvar = get_global '_tcl_unsetvar'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_unsetvar(interp,var,flags)
+
+    .return(res)
+.end
+
+=item UnsetVar2 (VARNAME1, VARNAME2, FLAGS)
+
+Unsets the element VARNAME1(VARNAME2) of a Tcl array.
+The optional argument FLAGS behaves as in I<setvar>.
+
+=back
+
+=cut
+
+.sub unsetvar2 :method
+    .param string name1
+    .param string name2
+    .param int flags :optional
+    .param int has_flags :opt_flag
+
+    .local pmc f_unsetvar2
+    f_unsetvar2 = get_global '_tcl_unsetvar2'
+    .local pmc interp
+    interp = getattribute self,'interp'
+    .local int flags
+
+    .Unless(has_flags,{
+        flags = 0
+    })
+
+    .local string res
+    res = f_unsetvar2(interp,name1,name2,flags)
+
+    .return(res)
+.end
+
+=item MainLoop
+
+MainLoop method, which corresponds to Tcl/Tk Tk_MainLoop call
+
+=back
+
+=cut
+
 .sub MainLoop :method
-    say "MainLoop"
-    # TO BE FIXED
-    self.'eval'(<<'EOS')
-while {[winfo exists .]} {
-    update
-}
-EOS
-#    .local pmc libtcl, f_mainloop
-#    libtcl = get_global '_libtcl'
-#    f_mainloop = dlfunc libtcl, "Tk_MainLoop", "v"
-#    f_mainloop()
-    say "MainLoop-e!"
+    # essentially we want to do:
+    #   .local pmc f_mainloop
+    #   f_mainloop = dlfunc libtk, "Tk_MainLoop", "v"
+    #   f_mainloop()
+    # we do not have libtk variable, however.
+    # providing iface with libtk is easy, but we can avoid this
+    # Instead of calling Tk_MainLoop, which is located in libtk8.5.so
+    # we do same loop as in Tcl::Tk module. So loading tk shared library
+    # is done by tcl itself.
+    .local string res
+    .local pmc libtcl
+    .local pmc f_dooneevent, f_eval, f_getstringresult
+    libtcl = get_global '_libtcl'
+    f_eval = get_global '_tcl_eval'
+    f_getstringresult = get_global '_tcl_getstringresult'
+    f_dooneevent = dlfunc libtcl, "Tcl_DoOneEvent", "ii"
+    .local pmc interp
+    interp = getattribute self,'interp'
+
+    # Loop until mainwindow exists (its path is '.')
+    # below are 2 implementations how we get know that mainwindow no more avail
+    #  1. eval "winfo exists ."
+    #  2. use global variable, which will be destroyed upon exit
+    # Now we prefer 2nd method.
+    .IfElse(0==1,{
+        .DoWhile({
+            f_dooneevent(0)  # spin it
+            # check if '.' window still exists
+            f_eval(interp, 'winfo exists .')
+            res = f_getstringresult(interp,0)
+        },res=="1")
+    },{
+        .local pmc f_getvar
+        f_getvar = get_global '_tcl_getvar'
+        self.'setvar'("MainLoop_continuing","y",TCL_GLOBAL_ONLY)
+        f_eval(interp,"trace add command . delete {unset MainLoop_continuing}")
+        .DoWhile({
+            f_dooneevent(0)  # spin it
+            # check if flag variable "MainLoop_continuing" still exists
+            res = f_getvar(interp,"MainLoop_continuing",TCL_GLOBAL_ONLY)
+         },res=="y")
+    })
+
 .end
 
 =item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)
diff -bru parrot-41587-o/t/library/tcl_lib.t parrot-41587/t/library/tcl_lib.t
--- parrot-41587-o/t/library/tcl_lib.t  Fri Jul 24 19:07:00 2009
+++ parrot-41587/t/library/tcl_lib.t    Fri Oct  2 17:34:59 2009
@@ -39,6 +39,8 @@
 
     .local string res
     .local int ires
+
+    # misc evals
     res = tcl.'eval'("return {3+3}")
     'is'(res, '3+3', 'return of a string')
     # TODO res = tcl.'eval'("return [list a b foo bar]")
@@ -47,6 +49,27 @@
     res = tcl.'eval'("return [expr 1.0]")
     'is'(res, '1.0', 'return of double')
 
+    # variable nethods: getvar, setvar2, unsetvar2, etc.
+    tcl.'setvar'("foo", "ok")
+    res = tcl.'eval_str'("set foo")
+    'is'(res,"ok", "setvar ok")
+    res = tcl.'eval_str'("return $foo")
+    'is'(res,"ok", "setvar ok")
+
+    tcl.'eval_str'('set a(OK) ok; set a(five) 5')
+    res = tcl.'getvar2'('a','OK')
+    'is'(res,'ok','getvar2 ok')
+    tcl.'setvar2'("foo", "bar", "ok")
+    res = tcl.'getvar2'('foo','bar')
+    'is'(res,'ok','setvar2 ok')
+    res = tcl.'eval_str'("set bar(foo)")
+    'is'(res,"ok", "setvar ok")
+    res = tcl.'eval_str'("return $foo(bar)")
+    'is'(res,"ok", "setvar ok")
+
+    # MORE TBD
+
+
 skip_all:
 
 .end