File Coverage

blib/lib/Tcl.pm
Criterion Covered Total %
statement 13 209 6.2
branch 0 74 0.0
condition 0 40 0.0
subroutine 5 23 21.7
pod n/a
total 18 346 5.2


line stmt bran cond sub pod time code
1             package Tcl;
2              
3             $Tcl::VERSION = '1.04';
4              
5             =head1 NAME
6              
7             Tcl - Tcl extension module for Perl
8              
9             =head1 SYNOPSIS
10              
11             use Tcl;
12              
13             $interp = Tcl->new;
14             $interp->Eval('puts "Hello world"');
15              
16             =head1 DESCRIPTION
17              
18             The Tcl extension module gives access to the Tcl library with
19             functionality and interface similar to the C functions of Tcl.
20             In other words, you can
21              
22             =over
23              
24             =item *
25              
26             create Tcl interpreters
27              
28             The Tcl interpreters so created are Perl objects whose destructors
29             delete the interpreters cleanly when appropriate.
30              
31             =item *
32              
33             execute Tcl code in an interpreter
34              
35             The code can come from strings, files or Perl filehandles.
36              
37             =item *
38              
39             bind in new Tcl procedures
40              
41             The new procedures can be either C code (with addresses presumably
42             obtained using I and I) or Perl subroutines
43             (by name, reference or as anonymous subs). The (optional) deleteProc
44             callback in the latter case is another perl subroutine which is called
45             when the command is explicitly deleted by name or else when the
46             destructor for the interpreter object is explicitly or implicitly called.
47              
48             =item *
49              
50             Manipulate the result field of a Tcl interpreter
51              
52             =item *
53              
54             Set and get values of variables in a Tcl interpreter
55              
56             =item *
57              
58             Tie perl variables to variables in a Tcl interpreter
59              
60             The variables can be either scalars or hashes.
61              
62             =back
63              
64             =head2 Methods in class Tcl
65              
66             To create a new Tcl interpreter, use
67              
68             $interp = Tcl->new;
69              
70             The following methods and routines can then be used on the Perl object
71             returned (the object argument omitted in each case).
72              
73             =over
74              
75             =item $interp->Init ()
76              
77             Invoke I on the interpreter.
78              
79             =item $interp->CreateSlave (NAME, SAFE)
80              
81             Invoke I on the interpeter. Name is arbitrary.
82             The safe variable, if true, creates a safe sandbox interpreter.
83             See: http://www.tcl.tk/software/plugin/safetcl.html
84             http://www.tcl.tk/man/tcl8.4/TclCmd/safe.htm
85              
86             This command returns a new interpreter.
87              
88             =item $interp->Eval (STRING, FLAGS)
89              
90             Evaluate script STRING in the interpreter. If the script returns
91             successfully (TCL_OK) then the Perl return value corresponds to Tcl
92             interpreter's result otherwise a I exception is raised with the $@
93             variable corresponding to Tcl's interpreter result object. In each case,
94             I means that if the method is called in scalar context then
95             the string result is returned but if the method is called in list context
96             then the result is split as a Tcl list and returned as a Perl list.
97             The FLAGS field is optional and can be a bitwise OR of the constants
98             Tcl::EVAL_GLOBAL or Tcl::EVAL_DIRECT.
99              
100             =item $interp->GlobalEval (STRING)
101              
102             REMOVED. Evalulate script STRING at global level.
103             Call I(STRING, Tcl::EVAL_GLOBAL) instead.
104              
105             =item $interp->EvalFile (FILENAME)
106              
107             Evaluate the contents of the file with name FILENAME. Otherwise, the
108             same as I() above.
109              
110             =item $interp->EvalFileHandle (FILEHANDLE)
111              
112             Evaluate the contents of the Perl filehandle FILEHANDLE. Otherwise, the
113             same as I() above. Useful when using the filehandle DATA to tack
114             on a Tcl script following an __END__ token.
115              
116             =item $interp->call (PROC, ARG, ...)
117              
118             Looks up procedure PROC in the interpreter and invokes it using Tcl's eval
119             semantics that does command tracing and will use the ::unknown (AUTOLOAD)
120             mechanism. The arguments (ARG, ...) are not passed through the Tcl parser.
121             For example, spaces embedded in any ARG will not cause it to be split into
122             two Tcl arguments before being passed to PROC.
123              
124             Before invoking procedure PROC special processing is performed on ARG list:
125              
126             1. All subroutine references within ARG will be substituted with Tcl name
127             which is responsible to invoke this subroutine. This Tcl name will be
128             created using CreateCommand subroutine (see below).
129              
130             2. All references to scalars will be substituted with names of Tcl variables
131             transformed appropriately.
132              
133             These first two items allows one to write and expect it to work properly such
134             code as:
135              
136             my $r = 'aaaa';
137             button(".d", -textvariable => \$r, -command=>sub {$r++});
138              
139             3. All references to hashes will be substituted with names of Tcl array
140             variables transformed appropriately.
141              
142             4. As a special case, there is a mechanism to deal with Tk's special event
143             variables (they are mentioned as '%x', '%y' and so on throughout Tcl).
144             When creating a subroutine reference that uses such variables, you must
145             declare the desired variables using Tcl::Ev as the first argument to the
146             subroutine. Example:
147              
148             sub textPaste {
149             my ($x,$y,$w) = @_;
150             widget($w)->insert("\@$x,$y", $interp->Eval('selection get'));
151             }
152             $widget->bind('<2>', [\&textPaste, Tcl::Ev('%x', '%y'), $widget] );
153              
154             =item $interp->return_ref (NAME)
155              
156             returns a reference corresponding to NAME, which was associated during
157             previously called C<< $interpnt->call(...) >> preprocessing. As a typical
158             example this could be variable associated with a widget.
159              
160             =item $interp->delete_ref (NAME)
161              
162             deletes and returns a reference corresponding to NAME, which was associated
163             during previously called C<< $interpnt->call(...) >> preprocessing.
164              
165             =item $interp->icall (PROC, ARG, ...)
166              
167             Looks up procedure PROC in the interpreter and invokes it using Tcl's eval
168             semantics that does command tracing and will use the ::unknown (AUTOLOAD)
169             mechanism. The arguments (ARG, ...) are not passed through the Tcl parser.
170             For example, spaces embedded in any ARG will not cause it to be split into
171             two Tcl arguments before being passed to PROC.
172              
173             This is the lower-level procedure that the 'call' method uses. Arguments
174             are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array
175             becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse
176             conversion is done to the result.
177              
178             =item $interp->invoke (PROC, ARG, ...)
179              
180             Looks up procedure PROC in the interpreter and invokes it directly with
181             arguments (ARG, ...) without passing through the Tcl parser. For example,
182             spaces embedded in any ARG will not cause it to be split into two Tcl
183             arguments before being passed to PROC. This differs from icall/call in
184             that it directly invokes the command name without allowing for command
185             tracing or making use of Tcl's unknown (AUTOLOAD) mechanism. If the
186             command does not already exist in the interpreter, and error will be
187             thrown.
188              
189             Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV
190             array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The
191             reverse conversion is done to the result.
192              
193             =item Tcl::Ev (FIELD, ...)
194              
195             Used to declare %-substitution variables of interest to a subroutine
196             callback. FIELD is expected to be of the form "%#" where # is a single
197             character, and multiple fields may be specified. Returns a blessed object
198             that the 'call' method will recognize when it is passed as the first
199             argument to a subroutine in a callback. See description of 'call' method
200             for details.
201              
202             =item $interp->result ()
203              
204             Returns the current Tcl interpreter result. List v. scalar context is
205             handled as in I() above.
206              
207             =item $interp->CreateCommand (CMDNAME, CMDPROC, CLIENTDATA, DELETEPROC, FLAGS)
208              
209             Binds a new procedure named CMDNAME into the interpreter. The
210             CLIENTDATA and DELETEPROC arguments are optional. There are two cases:
211              
212             (1) CMDPROC is the address of a C function
213              
214             (presumably obtained using I and I. In this case
215             CLIENTDATA and DELETEPROC are taken to be raw data of the ClientData and
216             deleteProc field presumably obtained in a similar way.
217              
218             (2) CMDPROC is a Perl subroutine
219              
220             (either a sub name, a sub reference or an anonymous sub). In this case
221             CLIENTDATA can be any perl scalar (e.g. a ref to some other data) and
222             DELETEPROC must be a perl sub too. When CMDNAME is invoked in the Tcl
223             interpreter, the arguments passed to the Perl sub CMDPROC are
224              
225             (CLIENTDATA, INTERP, LIST)
226              
227             where INTERP is a Perl object for the Tcl interpreter which called out
228             and LIST is a Perl list of the arguments CMDNAME was called with.
229             If the 1-bit of FLAGS is set then the 3 first arguments on the call
230             to CMDPROC are suppressed.
231             As usual in Tcl, the first element of the list is CMDNAME itself.
232             When CMDNAME is deleted from the interpreter (either explicitly with
233             I or because the destructor for the interpreter object
234             is called), it is passed the single argument CLIENTDATA.
235              
236             =item $interp->DeleteCommand (CMDNAME)
237              
238             Deletes command CMDNAME from the interpreter. If the command was created
239             with a DELETEPROC (see I above), then it is invoked at
240             this point. When a Tcl interpreter object is destroyed either explicitly
241             or implicitly, an implicit I happens on all its currently
242             registered commands.
243              
244             =item $interp->SetResult (STRING)
245              
246             Sets Tcl interpreter result to STRING.
247              
248             =item $interp->AppendResult (LIST)
249              
250             Appends each element of LIST to Tcl's interpreter result object.
251              
252             =item $interp->AppendElement (STRING)
253              
254             Appends STRING to Tcl interpreter result object as an extra Tcl list element.
255              
256             =item $interp->ResetResult ()
257              
258             Resets Tcl interpreter result.
259              
260             =item $interp->SplitList (STRING)
261              
262             Splits STRING as a Tcl list. Returns a Perl list or the empty list if
263             there was an error (i.e. STRING was not a properly formed Tcl list).
264             In the latter case, the error message is left in Tcl's interpreter
265             result object.
266              
267             =item $interp->SetVar (VARNAME, VALUE, FLAGS)
268              
269             The FLAGS field is optional. Sets Tcl variable VARNAME in the
270             interpreter to VALUE. The FLAGS argument is the usual Tcl one and
271             can be a bitwise OR of the constants Tcl::GLOBAL_ONLY,
272             Tcl::LEAVE_ERR_MSG, Tcl::APPEND_VALUE, Tcl::LIST_ELEMENT.
273              
274             =item $interp->SetVar2 (VARNAME1, VARNAME2, VALUE, FLAGS)
275              
276             Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional
277             argument FLAGS behaves as in I above.
278              
279             =item $interp->GetVar (VARNAME, FLAGS)
280              
281             Returns the value of Tcl variable VARNAME. The optional argument FLAGS
282             behaves as in I above.
283              
284             =item $interp->GetVar2 (VARNAME1, VARNAME2, FLAGS)
285              
286             Returns the value of the element VARNAME1(VARNAME2) of a Tcl array.
287             The optional argument FLAGS behaves as in I above.
288              
289             =item $interp->UnsetVar (VARNAME, FLAGS)
290              
291             Unsets Tcl variable VARNAME. The optional argument FLAGS
292             behaves as in I above.
293              
294             =item $interp->UnsetVar2 (VARNAME1, VARNAME2, FLAGS)
295              
296             Unsets the element VARNAME1(VARNAME2) of a Tcl array.
297             The optional argument FLAGS behaves as in I above.
298              
299             =back
300              
301             =head2 Linking Perl and Tcl variables
302              
303             You can I a Perl variable (scalar or hash) into class Tcl::Var
304             so that changes to a Tcl variable automatically "change" the value
305             of the Perl variable. In fact, as usual with Perl tied variables,
306             its current value is just fetched from the Tcl variable when needed
307             and setting the Perl variable triggers the setting of the Tcl variable.
308              
309             To tie a Perl scalar I<$scalar> to the Tcl variable I in
310             interpreter I<$interp> with optional flags I<$flags> (see I
311             above), use
312              
313             tie $scalar, "Tcl::Var", $interp, "tclscalar", $flags;
314              
315             Omit the I<$flags> argument if not wanted.
316              
317             To tie a Perl hash I<%hash> to the Tcl array variable I in
318             interpreter I<$interp> with optional flags I<$flags>
319             (see I above), use
320              
321             tie %hash, "Tcl::Var", $interp, "array", $flags;
322              
323             Omit the I<$flags> argument if not wanted. Any alteration to Perl
324             variable I<$hash{"key"}> affects the Tcl variable I
325             and I.
326              
327             =head2 Accessing Perl from within Tcl
328              
329             After creation of Tcl interpreter, in addition to evaluation of Tcl/Tk
330             commands within Perl, other way round also instantiated. Within a special
331             namespace C< ::perl > following objects are created:
332              
333             ::perl::Eval
334              
335             So it is possible to use Perl objects from within Tcl.
336              
337             =head2 Moving Tcl/Tk around with Tcl.pm
338              
339             NOTE: explanations below is for developers managing Tcl/Tk installations
340             itself, users should skip this section.
341              
342             In order to create Tcl/Tk application with this module, you need to make
343             sure that Tcl/Tk is available within visibility of this module. There are
344             many ways to achieve this, varying on ease of starting things up and
345             providing flexible moveable archived files.
346              
347             Following list enumerates them, in order of increased possibility to change
348             location.
349              
350             =over
351              
352             =item *
353              
354             First method
355              
356             Install Tcl/Tk first, then install Perl module Tcl, so installed Tcl/Tk will
357             be used. This is most normal approach, and no care of Tcl/Tk distribution is
358             taken on Perl side (this is done on Tcl/Tk side)
359              
360             =item *
361              
362             Second method
363              
364             Copy installed Tcl/Tk binaries to some location, then install Perl module Tcl
365             with a special action to make Tcl.pm know of this location. This approach
366             makes sure that only chosen Tcl installation is used.
367              
368             =item *
369              
370             Third method
371              
372             During compiling Tcl Perl module, Tcl/Tk could be statically linked into
373             module's shared library and all other files zipped into a single archive, so
374             each file extracted when needed.
375              
376             To link Tcl/Tk binaries, prepare their libraries and then instruct Makefile.PL
377             to use these libraries in a link stage.
378             (TODO provide better detailed description)
379              
380             =back
381              
382             =cut
383              
384 12     12   24759 use strict;
  12         19  
  12         14821  
385              
386             our $DL_PATH;
387             unless (defined $DL_PATH) {
388             $DL_PATH = $ENV{PERL_TCL_DL_PATH} || $ENV{PERL_TCL_DLL} || "";
389             }
390              
391             =ignore
392             sub Tcl::seek_tkkit {
393             # print STDERR "wohaaa!\n";
394             unless ($DL_PATH) {
395             require Config;
396             for my $inc (@INC) {
397             my $tkkit = "$inc/auto/Tcl/tkkit.$Config::Config{so}";
398             if (-f $tkkit) {
399             $DL_PATH = $tkkit;
400             last;
401             }
402             }
403             }
404             }
405             =cut
406             seek_tkkit() if defined &seek_tkkit;
407              
408              
409             my $path;
410             if ($^O eq 'darwin') {
411             # Darwin 7.9 (OS X 10.3) requires the path of the executable be prepended
412             # for #! scripts to operate properly (avoids RegisterProcess error).
413             require Config;
414             unless (grep { $_ eq $Config::Config{binexp} } split $Config::Config{path_sep}, $ENV{PATH}) {
415             $path = join $Config::Config{path_sep}, $Config::Config{binexp}, $ENV{PATH};
416             }
417             }
418              
419             require XSLoader;
420              
421             {
422             local $ENV{PATH} = $path if $path;
423             XSLoader::load('Tcl', $Tcl::VERSION);
424             }
425              
426             sub new {
427 0     0     my $int = _new(@_);
428 0           return $int;
429             }
430              
431             END {
432 12     12   82 Tcl::_Finalize();
433             }
434              
435             # %anon_refs keeps track of anonymous subroutines and scalar/array/hash
436             # references which are created on the fly for tcl/tk interchange
437             # at a step when 'call' interpreter method prepares its arguments for
438             # tcl/tk call, which is invoked by 'icall' interpreter method
439             # (this argument transformation is done with "CreateCommand" method for
440             # subs and with 'tie' for other)
441              
442             my %anon_refs;
443              
444             # (TODO -- find out how to check for refcounting and proper releasing of
445             # resources)
446              
447             # Subroutine "call" preprocess the arguments for special cases
448             # and then calls "icall" (implemented in Tcl.xs), which invokes
449             # the command in Tcl.
450             sub call {
451 0     0     my $interp = shift;
452 0           my @args = @_;
453 0           my $current_r = join ' ', grep {defined} grep {!ref} @args;
  0            
  0            
454 0           my @codes;
455              
456             # Process arguments looking for special cases
457 0           for (my $argcnt=0; $argcnt<=$#args; $argcnt++) {
458 0           my $arg = $args[$argcnt];
459 0           my $ref = ref($arg);
460 0 0         next unless $ref;
461 0 0 0       if ($ref eq 'CODE' || $ref eq 'Tcl::Code') {
    0 0        
    0 0        
    0          
    0          
462             # We have been passed something like \&subroutine
463             # Create a proc in Tcl that invokes this subroutine (no args)
464 0           $args[$argcnt] = $interp->create_tcl_sub($arg, undef, undef, $current_r);
465 0           push @codes, $anon_refs{$current_r}; # push CODE also only to keep it from early disposal
466             }
467             elsif ($ref eq 'SCALAR') {
468             # We have been passed something like \$scalar
469             # Create a tied variable between Tcl and Perl.
470              
471             # stringify scalar ref, create in ::perl namespace on Tcl side
472             # This will be SCALAR(0xXXXXXX) - leave it to become part of a
473             # Tcl array.
474 0           my $nm = "::perl::$arg";
475 0 0         unless (exists $anon_refs{$nm}) {
476 0           $anon_refs{$nm} = $arg;
477 0           my $s = $$arg;
478 0           tie $$arg, 'Tcl::Var', $interp, $nm;
479 0 0         $s = '' unless defined $s;
480 0           $$arg = $s;
481             }
482 0           $args[$argcnt] = $nm; # ... and substitute its name
483             }
484             elsif ($ref eq 'HASH') {
485             # We have been passed something like \%hash
486             # Create a tied variable between Tcl and Perl.
487              
488             # stringify hash ref, create in ::perl namespace on Tcl side
489             # This will be HASH(0xXXXXXX) - leave it to become part of a
490             # Tcl array.
491 0           my $nm = $arg;
492 0           $nm =~ s/\W/_/g; # remove () from stringified name
493 0           $nm = "::perl::$nm";
494 0 0         unless (exists $anon_refs{$nm}) {
495 0           $anon_refs{$nm} = $arg;
496 0           my %s = %$arg;
497 0           tie %$arg, 'Tcl::Var', $interp, $nm;
498 0           %$arg = %s;
499             }
500 0           $args[$argcnt] = $nm; # ... and substitute its name
501             }
502             elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') {
503             # We have been passed something like [\&subroutine, $arg1, ...]
504             # Create a proc in Tcl that invokes this subroutine with args
505 0           my $events;
506             # Look for Tcl::Ev objects as the first arg - these must be
507             # passed through for Tcl to evaluate. Used primarily for %-subs
508             # This could check for any arg ref being Tcl::Ev obj, but it
509             # currently doesn't.
510 0 0 0       if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') {
511 0           $events = splice(@$arg, 1, 1);
512             }
513             $args[$argcnt] =
514             $interp->create_tcl_sub(sub {
515 0     0     $arg->[0]->(@_, @$arg[1..$#$arg]);
516 0           }, $events, undef, $current_r);
517 0           push @codes, $anon_refs{$current_r};
518             }
519             elsif ($ref eq 'REF' and ref($$arg) eq 'SCALAR') {
520             # this is a very special shortcut: if we see construct like \\"xy"
521             # then place proper Tcl::Ev(...) for easier access
522 0           my $events = [map {"%$_"} split '', $$$arg];
  0            
523 0 0 0       if (ref($args[$argcnt+1]) eq 'ARRAY' &&
    0          
524             ref($args[$argcnt+1]->[0]) eq 'CODE') {
525 0           $arg = $args[$argcnt+1];
526             $args[$argcnt] =
527             $interp->create_tcl_sub(sub {
528 0     0     $arg->[0]->(@_, @$arg[1..$#$arg]);
529 0           }, $events, undef, $current_r);
530 0           push @codes, $anon_refs{$current_r};
531             }
532             elsif (ref($args[$argcnt+1]) eq 'CODE') {
533 0           $args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events, undef, $current_r);
534 0           push @codes, $anon_refs{$current_r};
535             }
536             else {
537 0           warn "not CODE/ARRAY expected after description of event fields";
538             }
539 0           splice @args, $argcnt+1, 1;
540             }
541             }
542              
543 0 0 0       if ($#codes>-1 and $args[0] eq 'after') {
544 0 0         if ($args[1] =~ /^\d+$/) {
    0          
545 0           my $id = $interp->icall(@args);
546             #print STDERR "rebind for $interp;$id\n";
547             # in 'after' methods, disposal of CODE REFs based on 'after' id
548             # i.e based on return value of tcl call
549 0           $anon_refs{"$interp;$id"} = \@codes;
550 0           delete $anon_refs{$current_r};
551             # plan deleting that entry, hence Tcl command during Tcl::Code::DESTROY
552             # TODO - this +1000 is wrong... should
553 0           $interp->invoke('after',$args[1]+1000, "perl::Eval {Tcl::_code_dispose('$interp;$id')}");
554 0           return $id;
555             } elsif ($args[1] eq 'idle') {
556             # no planned CODE REF disposal, just do as is
557 0           return $interp->icall(@args);
558             }
559             # if we're here - user does something wrong, but there is nothing we worry about
560             }
561              
562             # Done with special var processing. The only processing that icall
563             # will do with the args is efficient conversion of SV to Tcl_Obj.
564             # A SvIV will become a Tcl_IntObj, ARRAY refs will become Tcl_ListObjs,
565             # and so on. The return result from icall will do the opposite,
566             # converting a Tcl_Obj to an SV.
567              
568             # we need just this:
569             # return $interp->icall(@args);
570             # a bit of complications only to allow stack trace, i.e. in case of errors
571             # user will get error pointing to his program and not in this module.
572             # and also 'after' tcl method makes bit harder
573              
574 0 0         if (wantarray) {
575 0           my @res;
576 0           eval { @res = $interp->icall(@args); };
  0            
577 0 0         if ($@) {
578 0           require Carp;
579 0           Carp::confess ("Tcl error '$@' while invoking array result call:\n" .
580             "\t\"@args\"");
581             }
582 0           return @res;
583             } else {
584 0           my $res;
585 0           eval { $res = $interp->icall(@args); };
  0            
586 0 0         if ($@) {
587 0           require Carp;
588 0           Carp::confess ("Tcl error '$@' while invoking scalar result call:\n" .
589             "\t\"@args\"");
590             }
591 0           return $res;
592             }
593             }
594              
595             # create_tcl_sub will create TCL sub that will invoke perl CODE ref
596             # If $events variable is specified then special processing will be
597             # performed to provide needed '%' variables.
598             # If $tclname is specified then procedure will have namely that name,
599             # otherwise it will have machine-readable name.
600             # Returns tcl script suitable for using in tcl events.
601             sub create_tcl_sub {
602 0     0     my ($interp,$sub,$events,$tclname, $rname) = @_;
603 0 0         unless ($tclname) {
604             # stringify sub, becomes "CODE(0x######)" in ::perl namespace
605 0           $tclname = "::perl::$sub";
606             }
607              
608             #print STDERR "...=$rname\n";
609 0           $interp->CreateCommand($tclname, $sub, undef, undef, 1);
610              
611             # following line a bit more tricky than it seems to.
612             # because the whole intent of the %anon_refs hash is to have refcount
613             # of (possibly) anonymous sub that is happen to be passed,
614             # and, if passed for the same widget but arguments are same - then
615             # previous instance will be overwriten, and sub will be destroyed due
616             # to reference count, and Tcl method will also be destroyed during
617             # Tcl::Code::DESTROY
618 0           $anon_refs{$rname} = bless [\$sub, $interp], 'Tcl::Code';
619              
620 0 0         if ($events) {
621             # Add any %-substitutions to callback
622 0           $tclname = "$tclname " . join(' ', @{$events});
  0            
623             }
624 0           return $tclname;
625             }
626              
627             sub _code_dispose {
628 0     0     my $k = shift;
629             #print STDERR "_code_dispose $k\n";
630             #my $int = $anon_refs{$k}->[0]->[1];
631             #my @r = $int->Eval("after info $id"); # why do not work?
632             #print STDERR "r=@r\n";
633 0           delete $anon_refs{$k};
634             }
635              
636              
637             sub Ev {
638 0     0     my @events = @_;
639 0           return bless \@events, "Tcl::Ev";
640             }
641              
642              
643             package Tcl::Code;
644              
645             # only purpose is to track CODE REFs passed to 'call' method
646             # (often these are anon subs)
647             # so to bless it to this package and then catch deleting it, so
648             # to do cleaning up
649              
650             sub DESTROY {
651 0     0     my $rsub = $_[0]->[0];
652 0           my $interp = $_[0]->[1];
653 0           my $tclname = "::perl::$$rsub";
654             #print STDERR "CODE::DESTROY[[@_]] $tclname\n";
655 0 0         $interp->DeleteCommand($tclname) if defined $tclname;
656             }
657              
658             package Tcl::List;
659              
660 12         103 use overload '""' => \&as_string,
661 12     12   13459 fallback => 1;
  12         10888  
662              
663             package Tcl::Var;
664              
665             sub TIESCALAR {
666 0     0     my $class = shift;
667 0           my @objdata = @_;
668 0 0 0       unless (@_ == 2 || @_ == 3) {
669 0           require Carp;
670 0           Carp::croak('Usage: tie $s, Tcl::Var, $interp, $varname [, $flags]');
671             };
672 0           bless \@objdata, $class;
673             }
674              
675             sub TIEHASH {
676 0     0     my $class = shift;
677 0           my @objdata = @_;
678 0 0 0       unless (@_ == 2 || @_ == 3) {
679 0           require Carp;
680 0           Carp::croak('Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags]');
681             }
682 0           bless \@objdata, $class;
683             }
684              
685             my %arraystates;
686             sub FIRSTKEY {
687 0     0     my $obj = shift;
688 0           die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"
  0            
689 0 0 0       unless @{$obj} == 2 || @{$obj} == 3;
  0            
  0            
690 0           my ($interp, $varname, $flags) = @$obj;
691 0           $arraystates{$varname} = $interp->invoke("array","startsearch",$varname);
692 0           my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname});
693 0 0         if ($r eq '') {
694 0           delete $arraystates{$varname};
695 0           return undef;
696             }
697 0           return $r;
698             }
699             sub NEXTKEY {
700 0     0     my $obj = shift;
701 0           die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"
  0            
702 0 0 0       unless @{$obj} == 2 || @{$obj} == 3;
  0            
  0            
703 0           my ($interp, $varname, $flags) = @$obj;
704 0           my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname});
705 0 0         if ($r eq '') {
706 0           delete $arraystates{$varname};
707 0           return undef;
708             }
709 0           return $r;
710             }
711             sub CLEAR {
712 0     0     my $obj = shift;
713 0           die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"
  0            
714 0 0 0       unless @{$obj} == 2 || @{$obj} == 3;
  0            
  0            
715 0           my ($interp, $varname, $flags) = @$obj;
716 0           $interp->invoke("array", "unset", "$varname");
717             #$interp->invoke("array", "set", "$varname", "");
718             }
719             sub DELETE {
720 0     0     my $obj = shift;
721 0 0 0       unless (@{$obj} == 2 || @{$obj} == 3) {
  0            
  0            
722 0           require Carp;
723 0           Carp::croak("STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)");
  0            
  0            
724             }
725 0           my ($interp, $varname, $flags) = @{$obj};
  0            
726 0           my ($str1) = @_;
727 0           $interp->invoke("unset", "$varname($str1)"); # protect strings?
728             }
729              
730             sub UNTIE {
731 0     0     my $ref = shift;
732             #print STDERR "UNTIE:$ref(@_)\n";
733             }
734             sub DESTROY {
735 0     0     my $ref = shift;
736 0           delete $anon_refs{$ref->[1]};
737             }
738              
739             # This is the perl equiv to the C version, for reference
740             #
741             #sub STORE {
742             # my $obj = shift;
743             # croak "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"
744             # unless @{$obj} == 2 || @{$obj} == 3;
745             # my ($interp, $varname, $flags) = @{$obj};
746             # my ($str1, $str2) = @_;
747             # if ($str2) {
748             # $interp->SetVar2($varname, $str1, $str2, $flags);
749             # } else {
750             # $interp->SetVar($varname, $str1, $flags || 0);
751             # }
752             #}
753             #
754             #sub FETCH {
755             # my $obj = shift;
756             # croak "FETCH Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"
757             # unless @{$obj} == 2 || @{$obj} == 3;
758             # my ($interp, $varname, $flags) = @{$obj};
759             # my $key = shift;
760             # if ($key) {
761             # return $interp->GetVar2($varname, $key, $flags || 0);
762             # } else {
763             # return $interp->GetVar($varname, $flags || 0);
764             # }
765             #}
766              
767             package Tcl;
768              
769             =head1 Other Tcl interpreter methods
770              
771             =over 2
772              
773             =item export_to_tcl method
774              
775             An interpreter method, export_to_tcl, is used to expose a number of perl
776             subroutines and variables all at once into tcl/tk.
777              
778             B takes a hash as arguments, which represents named parameters,
779             with following allowed values:
780              
781             =over 4
782              
783             =item B => '...'
784              
785             tcl namespace, where commands and variables are to
786             be created, defaults to 'perl'. If '' is specified - then global
787             namespace is used. A possible '::' at end is stripped.
788              
789             =item B => { ... }
790              
791             anonymous hash of subs to be created in Tcl, in the form /tcl name/ => /code ref/
792              
793             =item B => { ... }
794              
795             anonymous hash of vars to be created in Tcl, in the form /tcl name/ => /code ref/
796              
797             =item B => '...'
798              
799             a name of Perl namespace, from where all existing subroutines will be searched
800             and Tcl command will be created for each of them.
801              
802             =item B => '...'
803              
804             a name of Perl namespace, from where all existing variables will be searched,
805             and each such variable will be tied to Tcl.
806              
807             =back
808              
809             An example:
810              
811             use strict;
812             use Tcl;
813            
814             my $int = Tcl->new;
815            
816             $tcl::foo = 'qwerty';
817             $int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl');
818            
819             $int->Eval(<<'EOS');
820             package require Tk
821            
822             button .b1 -text {a fluffy button} -command perl::fluffy_sub
823             button .b2 -text {a foo button} -command perl::foo
824             entry .e -textvariable perl::foo
825             pack .b1 .b2 .e
826             focus .b2
827            
828             tkwait window .
829             EOS
830            
831             sub tcl::fluffy_sub {
832             print "Hi, I am a fluffy sub\n";
833             }
834             sub tcl::foo {
835             print "Hi, I am foo\n";
836             $tcl::foo++;
837             }
838              
839             =cut
840              
841             sub export_to_tcl {
842 0     0     my $int = shift;
843 0           my %args = @_;
844              
845             # name of Tcl package to hold tcl commands bound to perl subroutines
846 0 0         my $tcl_namespace = (exists $args{namespace} ? $args{namespace} : 'perl::');
847 0           $tcl_namespace=~s/(?:::)?$/::/;
848              
849             # a batch of perl subroutines which tcl counterparts should be created
850 0   0       my $subs = $args{subs} || {};
851              
852             # a batch of perl variables which tcl counterparts should be created
853 0   0       my $vars = $args{vars} || {};
854              
855             # TBD:
856             # only => \@list_of_names
857             # argument to be able to limit the names to export to Tcl.
858              
859 0 0         if (exists $args{subs_from}) {
860             # name of Perl package, which subroutines would be bound to tcl commands
861 0           my $subs_from = $args{subs_from};
862 0           $subs_from =~ s/::$//;
863 12     12   9207 no strict 'refs';
  12         26  
  12         1766  
864 0           for my $name (keys %{"$subs_from\::"}) {
  0            
865             #print STDERR "$name;\n";
866 0 0         if (defined &{"$subs_from\::$name"}) {
  0            
867 0 0         if (exists $subs->{$name}) {
868 0           next;
869             }
870             #print STDERR "binding sub '$name'\n";
871 0           $int->CreateCommand("$tcl_namespace$name", \&{"$subs_from\::$name"}, undef, undef, 1);
  0            
872             }
873             }
874             }
875 0 0         if (exists $args{vars_from}) {
876             # name of Perl package, which subroutines would be bound to tcl commands
877 0           my $vars_from = $args{vars_from};
878 0           $vars_from =~ s/::$//;
879 12     12   55 no strict 'refs';
  12         19  
  12         3797  
880 0           for my $name (keys %{"$vars_from\::"}) {
  0            
881             #print STDERR "$name;\n";
882 0 0         if (defined ${"$vars_from\::$name"}) {
  0            
883 0 0         if (exists $vars->{$name}) {
884 0           next;
885             }
886             #print STDERR "binding var '$name' in '$tcl_namespace'\n";
887 0           local $_ = ${"$vars_from\::$name"};
  0            
888 0           tie ${"$vars_from\::$name"}, 'Tcl::Var', $int, "$tcl_namespace$name";
  0            
889 0           ${"$vars_from\::$name"} = $_;
  0            
890             }
891 0           if (0) {
892             # array, hash - no need to do anything.
893             # (or should we?)
894             }
895             }
896             }
897              
898 0           for my $subname (keys %$subs) {
899             #print STDERR "binding2 sub '$subname'\n";
900 0           $int->CreateCommand("$tcl_namespace$subname",$subs->{$subname}, undef, undef, 1);
901             }
902              
903 0           for my $varname (keys %$vars) {
904             #print STDERR "binding2 var '$varname'\n";
905 0 0         unless (ref($vars->{$varname})) {
906 0           require 'Carp.pm';
907 0           Carp::croak("should pass var ref as variable bind parameter");
908             }
909 0           local $_ = ${$vars->{$varname}};
  0            
910 0           tie ${$vars->{$varname}}, 'Tcl::Var', $int, "$tcl_namespace$varname";
  0            
911 0           ${$vars->{$varname}} = $_;
  0            
912             }
913             }
914              
915             =item B
916              
917             extra convenience sub, binds to tcl all subs and vars from perl B namespace
918              
919             =back
920              
921             =cut
922              
923             sub export_tcl_namespace {
924 0     0     my $int = shift;
925 0           $int->export_to_tcl(subs_from=>'tcl', vars_from=>'tcl');
926             }
927              
928             =head1 AUTHORS
929              
930             Malcolm Beattie, 23 Oct 1994
931             Vadim Konovalov, 19 May 2003
932             Jeff Hobbs, jeff (a) activestate . com, 22 Mar 2004
933             Gisle Aas, gisle (a) activestate . com, 14 Apr 2004
934              
935             Special thanks for contributions to Jan Dubois, Slaven Rezic, Paul Cochrane.
936              
937             =head1 COPYRIGHT
938              
939             This program is free software; you can redistribute it and/or modify it under
940             the same terms as Perl itself.
941              
942             See http://www.perl.com/perl/misc/Artistic.html
943              
944             =cut
945              
946             1;