[patch for 34031] first part of Tcl/Tk for parrot

[Vadim Konovalov]

在 Thursday 18 December 2008 19:09:05，Will Coleda 写道：
> On Thu, Dec 18, 2008 at 5:55 PM, Vadim Konovalov <vadrer at gmail.com> wrote:
> > it works for me (both linux and windows) but of course I'll investigate
> > what is going wrong
>
> FYI, This was on the linux box, feather.perl6.nl.

yes, I also see the error.
I'll take care of it.

>
> > I was intended to do subsequent patches, and surely :main will be in
> > example/ next time I'll submit my patch.

Ok, now I did a step further, and Tk GUI is properly shown.
tests, examples and descriptions are still to be done, 
sorry for the slow pace, surely I'll be faster soon :)
Actually programming parrot is fun, although I am just starting to get the 
taste :)

Please place TclLibrary to ./runtime/parrot/library/ and tcltkdemo.pir 
into ./examples/tcl/


> We're in the middle of changing how we do things so we probably have 3
> different ways listed in various docs.
>
> The best place today is at https://trac.parrot.org/

Right now I seemingly do not have a possibility:

Error: Forbidden
TICKET_CREATE privileges are required to perform this operation

I would be grateful for help in resolving this.
My user id is vkon

Thanks for your attention,
and best regards,
Vadim.
-------------- next part --------------
# Copyright (C) 2008, The Perl Foundation.
# vkon

=head1 TITLE

TclLibrary.pir - NCI interface to Tcl language (http://www.tcl.tk)

=head1 DESCRIPTION

This module implements Tcl/Tk interface for Parrot.

=cut


.namespace ['TclLibrary']


# derived from tcl.h:
.const int TCL_OK       = 0
.const int TCL_ERROR    = 1
.const int TCL_RETURN   = 2
.const int TCL_BREAK    = 3
.const int TCL_CONTINUE = 4


# 
.sub eval :method
    .param string str

    .local string res, error
    .local pmc f_evalex, f_getobjresult, f_getstringresult, f_resetresult
    f_resetresult = get_global '_tcl_resetresult'
    f_evalex = get_global '_tcl_evalex'
    f_getobjresult = get_global '_tcl_getobjresult'
    f_getstringresult = get_global '_tcl_getstringresult'

    .local pmc interp
    interp = getattribute self,'interp'

    f_resetresult(interp)

    .local int rc
    rc = f_evalex(interp,str,-1,0) # interp, string, length or -1, flags
    # check if the result is TCL_OK(=0)
    if rc==TCL_OK goto eval_ok
    res = f_getstringresult(interp,0)
    error = "error during Tcl_EvalEx: " . res
    die error

eval_ok:    
    # get the result (list result, etc - TBD)
    res = f_getstringresult(interp,0)
    .return(res)
.end

.sub instantiate :method
    # get interpreter, store it globally
    .local pmc interp, f_createinterp, f_tclinit
    .local pmc libtcl
    libtcl = get_global '_libtcl'
    f_createinterp = dlfunc libtcl, "Tcl_CreateInterp", "p"
    interp = f_createinterp()

    .local int b 
    b = isnull interp
    unless b goto ok_interp
    die "NO interp\n"

  ok_interp:
    setattribute self,'interp', interp
    f_tclinit = dlfunc libtcl, "Tcl_Init", "vp"
    f_tclinit(interp)
.end

.sub _tcl_init :load :init

    .local pmc tclclass
    tclclass = newclass ['TclLibrary']
    addattribute tclclass, 'interp'

    # load shared library
    .local pmc libnames
    libnames = new 'ResizableStringArray'
    push libnames, 'tcl85'
    push libnames, 'tcl84'
    push libnames, 'libtcl8.5'
    push libnames, 'libtcl8.4'
    .local pmc libtcl
    libtcl = _load_lib_with_fallbacks('tcl', libnames)
    set_global '_libtcl', libtcl

    # initialize Tcl library
    .local pmc func_findexec
    func_findexec = dlfunc libtcl, "Tcl_FindExecutable", "vp"
    func_findexec(0)

    # few more functions, store them globally
    .local pmc func
    # need: Tcl_ResetResult, Tcl_EvalEx, Tcl_GetStringResult
    func = dlfunc libtcl, "Tcl_ResetResult", "vp"
    set_global '_tcl_resetresult', func
    func = dlfunc libtcl, "Tcl_EvalEx", "iptii"
    set_global '_tcl_evalex', func
    func = dlfunc libtcl, "Tcl_GetStringFromObj", "tpp" # should be "tp3"
    set_global '_tcl_getstringfromobj', func
    func = dlfunc libtcl, "Tcl_GetStringResult", "tp"
    set_global '_tcl_getstringresult', func
    func = dlfunc libtcl, "Tcl_GetObjResult", "pp"
    set_global '_tcl_getobjresult', func

.end

.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!"
.end

=item _load_lib_with_fallbacks(string friendly_name, pmc fallback_list)

This function is more generally useful than just for this module -- it
implements the search for a particular libary that may appear under any
of several different filenames.  The C<fallback_list> should be a simple
array of strings, each naming one of the possible filenames, I<without>
the trailing shared library extension (e.g. C<.dll> or C<.so>).  The
C<friendly_name> is only used to fill in the error message in case no
match can be found on the system.

BORROWED from OpenGL.pir - keep an eye on it (e.g. if it will be organized
elsewhere - reuse it from there)

=cut

.sub _load_lib_with_fallbacks
    .param string friendly_name
    .param pmc    fallback_list

    .local pmc    list_iter
    list_iter = iter fallback_list

    .local string libname
    .local pmc    library
  iter_loop:
    unless list_iter goto failed
    libname = shift list_iter
    library = loadlib libname
    unless library goto iter_loop

  loaded:
    .return (library)

  failed:
    .local string message
    message  = 'Could not find a suitable '
    message .= friendly_name
    message .= ' shared library!'
    die message
.end




=head1 SEE ALSO

http://www.tcl.tk

=head1 AUTHORS

TBD

=cut


# Local Variables:
#   mode: pir
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir:
-------------- next part --------------
# demonstrate Tcl/Tk GUI using NCI

.include 'runtime/parrot/library/TclLibrary.pir'

.sub try :main
    .local pmc tcl
    tcl = new 'TclLibrary'
    tcl.'instantiate'()
    .local string res
    res = tcl.'eval'("puts this")
    res = tcl.'eval'("expr {2+3}")
    print "res="
    say res
    res = tcl.'eval'(<<"EOS")
package require Tk
pack [button .b -text {useful button} -command {puts this}]
pack [text .t]
.t insert end {foo, bar, fluffy}
pack [button .bquit -text {quit} -command {exit}]
EOS
    res = tcl.'eval'("expr {3+3}")
    print "res="
    say res
    tcl.'MainLoop'()
.end

#