File Coverage

blib/lib/Tcl/pTk.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package Tcl::pTk;
2            
3             our ($VERSION) = ('0.92');
4            
5 121     121   227237 use strict;
  121         159  
  121         3393  
6 121     121   123893 use Tcl;
  0            
  0            
7             use Exporter ('import');
8             use Scalar::Util (qw /blessed/); # Used only for it's blessed function
9             use AutoLoader; # Used for autoloading the Error routine
10             use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS $platform @cleanup_refs $cleanup_queue_maxsize $cleanupPending);
11            
12             # Wait till we have 100 things to delete before we do cleanup
13             $cleanup_queue_maxsize = 50;
14            
15             # Set the platform global variable, based on the OS we are running under
16             BEGIN{
17             if($^O eq 'cygwin')
18             {
19             $platform = 'MSWin32'
20             }
21             else
22             {
23             $platform = ($^O eq 'MSWin32') ? $^O : 'unix';
24             }
25             };
26            
27            
28             use Tcl::pTk::Widget;
29             use Tcl::pTk::MainWindow;
30             use Tcl::pTk::DialogBox;
31             use Tcl::pTk::Dialog;
32             use Tcl::pTk::LabEntry;
33             use Tcl::pTk::ROText;
34             use Tcl::pTk::Listbox;
35             use Tcl::pTk::Balloon;
36             use Tcl::pTk::Menu;
37             use Tcl::pTk::Menubutton;
38             use Tcl::pTk::Optionmenu;
39             use Tcl::pTk::Canvas;
40             use Tcl::pTk::Font;
41            
42            
43             # Tcl::pTk::libary variable: Translation from perl/tk Tk.pm
44             {($Tcl::pTk::library) = __FILE__ =~ /^(.*)\.pm$/;}
45             $Tcl::pTk::library = Tk->findINC('.') unless (defined($Tcl::pTk::library) && -d $Tcl::pTk::library);
46            
47            
48             # Global vars used by this package
49            
50             our ( %W, $Wint, $Wpath, $Wdata, $DEBUG, $inMainLoop, %widget_refs, $current_widget );
51             $current_widget = '';
52             # %widget_refs is an array to hold refs that were created when working with widgets
53            
54             # %anon_refs keeps track of anonymous subroutines that were created with
55             # "CreateCommand" method during process of transformation of arguments for
56             # "call" and other stuff such as scalar refs and so on.
57             our ( %anon_refs );
58            
59            
60             # For debugging, we use Sub::Name to name anonymous subs, this makes tracing the program
61             # much easier (using perl -d:DProf or other tools)
62             $DEBUG =0 unless defined($DEBUG);
63             if($DEBUG){
64             require Sub::Name;
65             import Sub::Name;
66             }
67            
68            
69             @Tcl::pTk::ISA = qw(Tcl);
70            
71            
72             sub WIDGET_CLEANUP() {1}
73            
74             $Tcl::pTk::DEBUG ||= 0;
75            
76             sub _DEBUG {
77             # Allow for optional debug level and message to be passed in.
78             # If level is passed in, return true only if debugging is at
79             # that level.
80             # If message is passed in, output that message if the level
81             # is appropriate (with any extra args passed to output).
82             my $lvl = shift;
83             return $Tcl::pTk::DEBUG unless defined $lvl;
84             my $msg = shift;
85             if (defined($msg) && ($Tcl::pTk::DEBUG >= $lvl)) { print STDERR $msg, @_; }
86             return ($Tcl::pTk::DEBUG >= $lvl);
87             }
88            
89            
90             =head1 NAME
91            
92             Tcl::pTk - Interface to Tcl/Tk with Perl/Tk compatible sytax
93            
94             =head1 SYNOPSIS
95            
96             B
97            
98             use Tcl::pTk;
99            
100             my $mw = MainWindow->new();
101             my $lab = $mw->Label(-text => "Hello world")->pack;
102             my $btn = $mw->Button(-text => "test", -command => sub {
103             $lab->configure(-text=>"[". $lab->cget('-text')."]");
104             })->pack;
105             MainLoop;
106            
107             Or B
108            
109             use Tcl::pTk;
110             my $int = new Tcl::pTk;
111             $int->Eval(<<'EOS');
112             # pure-tcl code to create widgets (e.g. generated by some GUI builder)
113             entry .e
114             button .inc -text {increment by Perl}
115             pack .e .inc
116             EOS
117             my $btn = $int->widget('.inc'); # get .inc button into play
118             my $e = $int->widget('.e'); # get .e entry into play
119             $e->configure(-textvariable=>\(my $var='aaa'));
120             $btn->configure(-command=>sub{$var++});
121             $int->MainLoop;
122            
123             =head1 DESCRIPTION
124            
125             C interfaces perl to an existing Tcl/Tk
126             installation on your computer. It has fully perl/tk (See L) compatible syntax for running existing
127             perl/tk scripts, as well as direct-tcl syntax for using any other Tcl/Tk features.
128            
129             Using this module an interpreter object is created, which
130             then provides access to all the installed Tcl libraries (Tk, Tix,
131             BWidgets, BLT, etc) and existing features (for example native-looking
132             widgets using the C package).
133            
134             B
135            
136             =over
137            
138             =item *
139            
140             Perl/Tk compatible syntax.
141            
142             =item *
143            
144             Pure perl megawidgets work just like in perl/tk. See the test case t/slideMegaWidget.t in the source distribution
145             for a simple example.
146            
147             =item *
148            
149             All the perl/tk widget demos work with minimal changes. Typically the only changes needed are just changing the "Use Tk;"
150             to "Use Tcl::pTk" at the top of the file. See the I demo script included in the source distribution to run the demos.
151            
152             =item *
153            
154             Built-in local drag-drop support, compatible with perl/tk drag-drop coding syntax.
155            
156             =item *
157            
158             L package supplied which enables Tcl::pTk to be used with existing Tk Scripts.
159            
160             =item *
161            
162             Similar interface approach to Tcl/Tk that other dynamic languages use (e.g. ruby, python). Because of this approach,
163             upgrades to Tcl/Tk shouldn't require much coding changes (if any) in L.
164            
165             =item *
166            
167             L package supplied, which provides a quick way of using the new better-looking Tile/ttk widgets in existing code.
168            
169             =item *
170            
171             TableMatrix (spreadsheet/grid Tktable widget, built to emulate the perl/tk L interface ) built into the package
172             (as long as you have the Tktable Tcl/Tk extension installed).
173            
174             =item *
175            
176             Extensive test suite.
177            
178             =item *
179            
180             Compatible with Tcl/Tk 8.4+
181            
182             =back
183            
184             =head2 Examples
185            
186             There are many examples in the I script (This is very simlar to the I demo installed with
187             perl/tk). After installing the L package, type I on the command line to run.
188            
189             The test cases in the I directory of the source distribution also is a good source of code examples.
190            
191             =head1 Relation to the L Package
192            
193             This package (L) is similar (and much of the code is derived from) the L package,
194             maintained by Vadim Konovalov. However it differs from the L package in some important ways:
195            
196             =over 1
197            
198             =item * L
199            
200             Emphasis is on 100% compatibility with existing perl/tk syntax.
201            
202             For developers with a perl/Tk background and an existing perl/Tk codebase to support.
203             For perl/Tk developers looking to take
204             advantage of the look/feel updates in Tcl/Tk 8.5 and above.
205            
206             =item * L
207            
208             Emphasis is on a lightweight interface to Tcl/Tk with syntax similar to (but not exactly like) perl/tk.
209            
210             For developers with some perl/Tk background, writing new code,
211             but no existing perl/Tk codebase to support.
212            
213             =back
214            
215             =head1 Basic Usage/Operation
216            
217             =head2 Creating a Tcl interpreter for Tk
218            
219             Before you start using widgets, an interpreter (at least one) should be
220             created, which will manage all things in Tcl. Creating an interpreter is created automatically
221             my the call to the C (or C) methods, but can also be created explicitly.
222            
223             B
224             For perl/tk syntax, the interpreter is created for you when you create the mainwindow.
225            
226             use Tcl::pTk;
227            
228             my $mw = MainWindow->new(); # Create Tcl::pTk interpreter and returns mainwindow widget
229             my $int = $mw->interp; # Get the intepreter that was created in the MainWindow call
230            
231             B
232            
233             use Tcl::pTk;
234            
235             my $int = new Tcl::pTk;
236            
237             Optionally a DISPLAY argument can be specified: C.
238             This creates a Tcl interpreter object $int, and creates a main toplevel
239             window. The window is created on display DISPLAY (defaulting to the display
240             named in the DISPLAY environment variable)
241            
242             =head2 Entering the main event loop
243            
244             B
245            
246             MainLoop; # Exact same syntax used as perl/Tk
247            
248             B
249            
250             $inst->MainLoop;
251            
252             =head2 Creating and using widgets
253            
254             Two different approaches are used to manipulate widgets (or to manipulate any Tcl objects that
255             act similarly to widgets).
256            
257             =over
258            
259             =item *
260            
261             Perl/Tk compatible-syntax approach. i.e. C<< $widget->method >> syntax.
262            
263             =item *
264            
265             Direct access using Eval-ed Tcl code. (e.g. using the C<< Eval >> Tcl::pTk method)
266            
267             =back
268            
269             The first way to manipulate widgets is identical to the perl/Tk calling conventions,
270             the second one uses Tcl syntax. Both ways are interchangeable in that a widget
271             created with one way can be used the another way. This interchangability enables
272             use of Tcl-code created elsewhere (e.g. by some WYSIWYG IDE).
273            
274             Usually Perl programs operate with Tcl::pTk via perl/Tk syntax, so users have no
275             need to deal with the Tcl language directly. Only some basic understanding of
276             Tcl/Tk widgets is needed.
277            
278            
279             =head3 Tcl/Tk syntax
280            
281             In order to get better understanding on usage of Tcl/Tk widgets from within
282             Perl, a bit of Tcl/Tk knowledge is needed, so we'll start from 2nd approach,
283             with Tcl's Eval (C<< $int->Eval('...') >>) and then smoothly move to first
284             approach with perl/Tk syntax.
285            
286             =over
287            
288             =item * The Tcl Interpreter
289            
290             The Tcl interpreter is used to process Tcl/Tk widgets; within C you
291             create it with C, and given any widget object, you can retreive it by the
292             C<< $widget->interp >> method. ( Within pure Tcl/Tk the interpreter already exists,
293             you don't need to create it explicitly. )
294            
295             =item * The Widget Path
296            
297             The Widget path is a string starting with a dot and consisting of several
298             names separated by dots. These names are individual widget-names that comprise
299             a widget's hierarchy. As an example, if there exists a frame with a path
300             C<.fram>, and you want to create a button on it and name it C, then
301             you should specify name C<.fram.butt>. Widget paths are also refered in
302             other miscellaneous widget operations, like geometry management.
303            
304             At any time a widget's path can be retreived with C<< $widget->path; >>
305             within C.
306            
307             =item * The Widget Path as a Tcl/Tk command
308            
309             When a widget is created in Tcl/Tk, a special command is created that is the name of the
310             widget's path. For example, a button created in a frame has a path and command-name C<.fr.b>. This
311             command also has subcommands which manipulate the widget. That is why
312             C<< $int->Eval('.fr.b configure -text {new text}'); >> makes sense.
313             Note that using perl/tk syntax C<< $button->configure(-text=>'new text'); >> does exactly the same thing,
314             if C<$button> corresponds to C<.fr.b> widget.
315            
316            
317             =back
318            
319            
320             The C statement not only creates the C package, but also creates the
321             C package, which is responsible for widgets. Each widget ( an object
322             blessed to C, or any of its subclasses )
323             behaves in such a way that its method will result in calling it's path on the
324             interpreter.
325            
326             =head3 Perl/Tk syntax
327            
328             C fully supports perl/Tk widget syntax of the L package, which has been used for many years. This means that any C widget
329             has a number of methods like C
330             on, and invoking those methods will create an appropriate child widget.
331             C will generate an unique path-name for a newly created widget.
332            
333             To demonstrate this concept, the perl/Tk syntax:
334            
335             my $label = $frame->Label(-text => "Hello world");
336            
337             executes the command
338            
339             $int->call("label", ".l", "-text", "Hello world");
340            
341             and this command similar to
342            
343             $int->Eval("label .l -text {Hello world}");
344            
345             This way Tcl::pTk widget commands are translated to Tcl syntax and directed to
346             the Tcl interpreter. This translation that occurs from perl/Tk syntax to Tcl calls is why the two approaches for
347             dealing with widgets are interchangeable.
348            
349             The newly created widget C<$label> will be blessed to package C
350             which is isa-C (i.e. C is a subclass of C).
351            
352            
353             =head1 Categories of Tcl::pTk Widgets
354            
355             C Widgets fall into the following basic categories, based on how they are implemented in the C package.
356            
357             =over 1
358            
359             =item Direct auto-wrapped widgets
360            
361             These types of widgets (for example the Entry, Button, Scrollbar, and Label widgets) have no special code written for them
362             in C. Their creation and method calls (e.g. C<$button->configure(-text => 'ButtonText')> ) are handled
363             by the wrapping code in the base Tcl::pTk::Widget package.
364            
365             =item Auto-wrapped widgets, with compatibility code
366            
367             These types of widgets are similar to the Direct auto-wraped widgets, but have additional code written to be completely
368             compatibile with the perl/Tk syntax. Examples of this type of widget are the Text, Frame, Menu, and Menubutton widgets.
369            
370             =item Megawidgets
371            
372             These are widgets that are composed of one-or-more other base widget types. Pure-perl megawidgets are supported in Tcl::pTk,
373             just like they are in perl/Tk. Examples of these types of widgets are ProgressBar, LabEntry, BrowseEntry, and SlideSwitch (one of the test cases in the source distribution).
374            
375             =item Derived Widgets
376            
377             Derived widgets are sub-classes of existing widgets that provide some additional functions. Derived widgets are created in
378             Tcl::pTk using very similar syntax to perl/Tk (i.e. using the Tcl::pTk::Derived package, similar to the Tk::Derived package).
379             Examples of these types of widgets are Tree, TextEdit, TextUndo, ROText, and DirTree.
380            
381             =back
382            
383             =head1 A behind-the-scenes look at auto-wrapped widgets
384            
385             All widgets in C are objects, and have an inheritance hierarchy that derives from the C
386             parent class. Megawidgets and derived widgets are handled very similar (if not exactly) the same as in perl/tk.
387            
388             Auto-wrapped widgets (like the Entry, Button, Scrollbar, etc.) are handled differently.
389             The object system for these types of widgets is dynamic. Classes and/or methods are created when they are
390             first used or needed.
391            
392             The following describes how methods are called for the two different categories of auto-wrapped widgets
393            
394             =over 1
395            
396             =item Direct auto-wrapped widget example
397            
398             Here is an example of a Entry widget, a direct auto-wrapped widget:
399            
400             my $entry = $mw->Entry->pack; # Create an entry widget and pack it
401             $entry->insert('end', -text=>'text'); # Insert some text into the Entry
402             my $entryText = $entry->get(); # Get the entry's text
403            
404             Internally, the following mechanics come into play:
405             The I method creates an I widget (known as C in the Tcl/Tk environment).
406             When this creation method is invoked the first time, a package
407             C is created, which sets up the class hierarchy for any
408             further Entry widgets. The newly-created C class is be
409             a direct subclass of C.
410            
411             The second code line above calls the C method of the C<$entry> object.
412             When invoked first time, a method (i.e. subref) C is
413             created in package C, which will end-up calling
414             calling the C method on the Tcl/Tk interpreter (i.e.
415             C<$entry->interp()->invoke($entry, 'insert', -text, 'text')
416            
417             The first time C is called, the C method does not exist, so AUTOLOAD
418             comes into play and creates the method. The second time C is called, the already-created
419             method is called directly (i.e. not created again), thus saving execution time.
420            
421             =item Auto-wrapped widgets, with compatibility code
422            
423             Here is an example of a Text widget, which is an auto-wrapped widget with extra
424             code added for compatibility with the perl/tk Text widget.
425            
426             my $text = $mw->Text->pack; # Create an text widget and pack it
427             $text->insert('end', -text=>'text'); # Insert some text into the Text
428             @names = $text->markNames; # Get a list of the marks set in the
429             # Text widget
430            
431             Internally, following mechanics come into play:
432             The I method creates an I widget (known as C in Tcl/Tk environment).
433             Because a C package already exists, a new package is not created
434             at runtime like the case above.
435            
436             The second code line above calls the C of the C<$text> object of type
437             C. This C method is already defined in the C package,
438             so it is called directly.
439            
440             The third code line above calls the C method on the C<$text> object. This method
441             is not defined in the C package, so the first time when C is called,
442             AUTOLOAD in the L package comes into play and creates the method.
443             The second time C is called, the already-created
444             method is called directly (i.e. not created again), thus saving execution time.
445            
446             =back
447            
448             =head2 Description of an auto-wrapped method call
449            
450             Suppose C<$widget> isa C, its path is C<.path>, and method
451             C invoked on it with a list of parameters, C<@parameters>:
452            
453             $widget->method(@parameters);
454            
455             In this case all C<@parameters> will be preprocessed by performing the following actions:
456            
457             =over
458            
459             =item 1.
460            
461             For each variable reference, a Tcl variable will be created and tied to it, so changes in the perl variable
462             will be reflected in the Tcl variable, and changes in the Tcl variable will show up in the perl variable.
463            
464             =item 2.
465            
466             For each perl code-reference, a Tcl command will be created that calls this perl code-ref.
467            
468             =item 3.
469            
470             Each array reference will considered a callback, and proper actions will be taken.
471            
472             =back
473            
474             After processing of C<@parameters>, the Tcl/Tk interpreter will be requested to
475             perform following operation:
476            
477             =over
478            
479             =item if C<$method> is all lowercase (e.g. C), C
480            
481             C<.path method parameter1 parameter2> I<....>
482            
483             =item if C<$method> contains exactly one capital letter inside the method name (e.g. C), C
484            
485             C<.path method submethod parameter1 parameter2> I<....>
486            
487             =item if C<$method> contains several capital letter inside the method name, C
488            
489             C<.path method submeth subsubmeth parameter1 parameter2> I<....>
490            
491             =back
492            
493             =head2 Fast method invocation for auto-wrapped widgets
494            
495             If you are sure that preprocessing of C<@parameters> in a method call aren't required
496             (i.e. no parameters are Perl references to scalars, subroutines or arrays), then
497             the preprocessing step described above can be skipped by calling the method with
498             an underscore C<_> prepended to the name. (e.g call C<$text->_markNames()>, instead of
499             C<$text->markNames()>). Calling the method this way means you are using an internal
500             method that executes faster, but normally you should use a "public" (i.e. non-underscore) method, which includes all preprocessing.
501            
502             Example:
503            
504             # Can't use the faster method-call here, because \$var must be
505             # preprocessed for Tcl/Tk:
506             $button->configure(-textvariable=>\$var);
507            
508             # Faster version of insert method for the "Text" widget
509             $text->_insert('end','text to insert','tag');
510            
511             # This line does exactly same thing as previous line:
512             $text->_insertEnd('text to insert','tag');
513            
514             When doing many inserts to a text widget, the faster version can help speed things up.
515            
516            
517             =head1 Using any Tcl/Tk feature from Tcl::pTk
518            
519             In addition to the standard widgets (e.g. Entry, Button, Menu, etc), the C module
520             lets you use any other widget from the Tcl/Tk widget library. This can be done with either
521             Tcl syntax (via the C method), or with regular perl/tk syntax.
522            
523             To interface to a new Tcl/Tk widget using perl/tk syntax, a C method call
524             is made on an already-created widget, or on the C interpreter object itself.
525            
526             Syntax is
527            
528             # Calling Declare on a widget object:
529             $widget->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
530             @options);
531            
532             or, exactly the same,
533            
534             # Calling Declare on a the Tcl::pTk Interpreter object:
535             $interp->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
536             @options);
537            
538             Options are:
539            
540             -require => 'tcl-package-name'
541             -prefix => 'some-prefix'
542            
543             The I<-require> option specifies the new Tcl/Tk widget requires a Tcl package to be loaded with a name
544             of 'tcl-package-name';
545            
546             The I<-prefix> option used to specify the prefix of the autogenerated widget path-name. This option is
547             normally used when the Tcl/Tk widget name contains non-alphabetic characters (e.g. ':'). If not specified, the
548             prefix will be generated from the package-name.
549            
550             A typical example of using the C method:
551            
552             $mw->Declare('BLTNoteBook','blt::tabnotebook',-require=>'BLT',-prefix=>'bltnbook');
553            
554             After this call, C will create a widget creation method for this new package to make it an
555             auto-wrapped widget (See the definition of auto-wrapped widgets above).
556            
557             This means
558            
559             my $tab = $mw->BLTNoteBook;
560            
561             will create blt::tabnotebook widget. Effectively, this is equavalent to the following
562             Tcl/Tk code:
563            
564             package require BLT # but invoked only once
565             blt::tabnotebook .bltnbook1
566            
567             After the above example code, the variable C<$tab> is a B that behaves in
568             the usual way, for example:
569            
570             $tab->insert('end', -text=>'text');
571             $tab->tabConfigure(0, -window=>$tab->Label(-text=>'text of label'));
572            
573             These two lines are the Tcl/Tk equivalent of:
574            
575             .bltnbook1 insert end -text {text}
576             .bltnbook1 tab configure 0 -window [label .bltnbook1.lab1 -text {text of label}]
577            
578             You can also intermix the perl/tk and Tcl/Tk syntax like this:
579            
580             $interp->Eval('package require BLT;blt::tabnotebook .bltnbook1');
581             $tab = $interp->widget('.bltnbook1');
582             $tab->tabConfigure(0, -window=>$tab->Label(-text=>'text of label'));
583            
584             =head1 How to read Tcl/Tk widget docs when using in C
585            
586             For the documentation of standard perl/tk widgets (like Button, Entry, Menu, etc), you can refer
587             to the the perl/tk docs L (We may move a copy of the perl/tk docs to Tcl::pTk in the future). For non-standard
588             widgets (like the BLTNotebook widget example above) you have to use the Tcl docs on the widget for the widget documentation. (Most Tcl/Tk
589             docs can be found at http://www.tcl.tk/ )
590            
591             When reading Tcl/Tk widget documentation about widgets, you can apply the following guidelines to determine how
592             to use the widget in C using perl/tk syntax.
593            
594             Suppose the Tcl/Tk docs say:
595            
596             pathName method-name optional-parameters
597             (some description)
598            
599             This means the widget has a has method C and you can
600             invoke it in C like
601            
602             $widget->method-name(optional-parameters);
603            
604             The C<$widget> variable in C is like the I in the Tcl/Tk docs.
605            
606             Sometimes the Tcl/Tk method-name consists of two words (verb1 verb2). In this
607             case there are two equivalent ways to invoke it, C< $widget->verb1('verb2',...); > or
608             C< $widget->verb1Verb2(...)>;
609            
610             Widget options are used just like they are shown in the Tcl/Tk docs. There is no special translation needed
611             for the widget options described in the Tcl/Tk docs for use in C.
612            
613             =head1 Miscellaneous methods
614            
615             =head2 C<< $int->widget( path, widget-type ) >>
616            
617             When widgets are created in C they are stored internally and can and can be retreived
618             by the C method, which takes widget path as first parameter, and optionally
619             the widget type (such as Button, or Text etc.). For Example:
620            
621             # this will retrieve widget, and then call configure on it
622             widget(".fram.butt")->configure(-text=>"new text");
623            
624             # this will retrieve widget as Button (Tcl::pTk::Button object)
625             my $button = widget(".fram.butt", 'Button');
626            
627             # same but retrieved widget considered as general widget, without
628             # specifying its type. This will make it a generic Tcl::pTk::Widget object
629             my $button = widget(".fram.butt");
630            
631             Please note that this method will return to you a widget object even if it was
632             not created within C. A check is not performed to see if a
633             widget with given path name exists. This enables the use of widgets created elsewhere
634             in Tcl/Tk to be treated like C widgets.
635            
636             =head2 C
637            
638             If you need to associate any data with particular widget, you can do this with
639             C method of either interpreter or widget object itself. This method
640             returns same anonymous hash and it should be used to hold any keys/values pairs.
641            
642             Examples:
643            
644             $interp->widget_data('.fram1.label2')->{var} = 'value';
645             $label->widget_data()->{var} = 'value';
646            
647             B
648            
649             Use of this method has largely been superceded by the perl/tk-compatible C widget method.
650            
651            
652            
653             =head2 C<< $widget->tooltip("text") >>
654            
655             Any widget accepts the C method, accepting any text as parameter, which
656             will be used as floating help text explaining the widget. The widget itself
657             is returned, so to provide convenient way of chaining:
658            
659             $mw->Button(-text=>"button 1")->tooltip("This is a button, m-kay")->pack;
660             $mw->Entry(-textvariable=>\my $e)->tooltip("enter the text here, m-kay")->pack;
661            
662             The C method uses the C package, which is a part of C within
663             Tcl/Tk, so be sure you have that Tcl/Tk package installed.
664            
665             Note: The perl/tk-compatible B widget is also available for installing tool-tips on widgets
666             and widget-elements.
667            
668            
669             =head1 Terminology
670            
671             In the documentation and comments for this package, I, I, I, I, and I are used. These terms have the
672             following meanings in the context of this package.
673            
674             =over 1
675            
676             =item perl/Tk
677            
678             The traditional perl interface to the Tk GUI libraries. i.e the perl package occupying the L namespace on CPAN.
679            
680             =item Tcl/Tk
681            
682             The Tcl/Tk package with tcl-code and associated libraries (e.g. Tcl.so or Tcl.dll and associated tcl-code). See http://www.tcl.tk/
683            
684             =item Tcl::pTk
685            
686             This package, which provides a perl interface into the Tcl/Tk GUI libraries.
687            
688             =item Tcl.pm
689            
690             The L perl package, which provides a simple interface from perl to Tcl/Tk. L interpreter objects are subclassed
691             from the L package.
692            
693             =item Tcl
694            
695             The I programming language.
696            
697             =back
698            
699            
700             =head1 BUGS
701            
702             Currently work is in progress, and some features could change in future
703             versions.
704            
705             =head1 AUTHORS
706            
707             =over
708            
709             =item Malcolm Beattie.
710            
711             =item Vadim Konovalov, vadim_tcltk@vkonovalov.ru 19 May 2003.
712            
713             =item Jeff Hobbs, jeffh _a_ activestate com, February 2004.
714            
715             =item Gisle Aas, gisle _a_ activestate . com, 14 Apr 2004.
716            
717             =item John Cerney, john.cerney _a_ gmail . com, 29 Sep 2009.
718            
719             =back
720            
721             =head1 COPYRIGHT
722            
723             This program is free software; you can redistribute it and/or modify it
724             under the same terms as Perl itself.
725            
726             See http://www.perl.com/perl/misc/Artistic.html
727            
728             =cut
729            
730             my @misc = qw( after destroy focus grab lower option place raise
731             image font
732             selection tk grid tkwait update winfo wm);
733             my @perlTk = qw( MainWindow MainLoop DoOneEvent tkinit update Ev Exists);
734            
735             # Flags for supplying to DoOneEvent
736             my @eventFlags = qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS
737             TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
738            
739             @EXPORT = (@perlTk, @eventFlags);
740             @EXPORT_OK = (@misc );
741             %EXPORT_TAGS = (widgets => [], misc => \@misc, perlTk => \@perlTk,
742             eventtypes => [@eventFlags],
743             );
744            
745             ## TODO -- module's private $tkinterp should go away!
746             my $tkinterp = undef; # this gets defined when "new" is done
747            
748             # Hash to keep track of all created widgets and related instance data
749             # Tcl::pTk will maintain PATH (Tk widget pathname) and INT (Tcl interp)
750             # and the user can create other info.
751             %W = (
752             INT => {}, # Hash of mainwindowID or pathname => Tcl::pTk Interpreter Reference
753             PATH => {}, # Hash of pathname => pathname (or mainwindow id)
754             RPATH => {}, # Hash of pathname => widget reference
755             DATA => {}, # Hash of widget data (used by the widget_data methods)
756             );
757             # few shortcuts for %W to be faster
758             $Wint = $W{INT};
759             $Wpath = $W{PATH};
760             $Wdata = $W{DATA};
761            
762            
763            
764             # hash to keep track on preloaded Tcl/Tk modules, such as Tix, BWidget
765             my %preloaded_tk; # (interpreter independent thing. is this right?)
766            
767             #
768             sub new {
769             my ($class, $display) = @_;
770             Carp::croak 'Usage: $interp = new Tcl::pTk([$display])'
771             if @_ > 1;
772             my @argv;
773             if (defined($display)) {
774             push(@argv, -display => $display);
775             } else {
776             $display = $ENV{DISPLAY} || '';
777             }
778             my $i = Tcl::_new();
779             bless $i, $class;
780             $i->SetVar2("env", "DISPLAY", $display, Tcl::GLOBAL_ONLY);
781             $i->SetVar("argv", [@argv], Tcl::GLOBAL_ONLY);
782             $i->SetVar("tcl_interactive", 0, Tcl::GLOBAL_ONLY);
783             $i->SUPER::Init();
784             $i->pkg_require('Tk', $i->GetVar('tcl_version'));
785            
786             my $mwid = $i->invoke('winfo','id','.');
787             $W{PATH}->{$mwid} = '.';
788             $W{INT}->{$mwid} = $i;
789             $W{mainwindow}->{"$i"} = bless({ winID => $mwid }, 'Tcl::pTk::MainWindow');
790            
791             # When mainwindow goes away, delete entry from the $W{mainwindow} global hash:
792             $i->call('trace', 'add', 'command', '.', 'delete',
793             sub { delete $W{mainwindow}{"$i"} }
794             );
795             $i->ResetResult();
796            
797             $Tcl::pTk::TK_VERSION = $i->GetVar("tk_version");
798             # Only do this for DEBUG() ?
799             $Tk::VERSION = $Tcl::pTk::TK_VERSION;
800             $Tk::VERSION =~ s/^(\d)\.(\d)/${1}0$2/;
801             unless (defined $tkinterp) {
802             # first call, create command-helper in TCL to trace widget destruction
803             $i->CreateCommand("::perl::w_del", \&widget_deletion_watcher);
804            
805             # Create command-helper in TCL to perform the actual widget cleanup
806             # (deferred in a afterIdle call )
807             $i->CreateCommand("::perl::w_cleanup", \&widget_cleanup);
808             }
809             $tkinterp = $i;
810            
811             # Create background error handling method that is similar to the way perltk does it
812             $tkinterp->CreateCommand('bgerror', \&Tcl::pTk::bgerror);
813            
814             return $i;
815             }
816            
817             sub mainwindow {
818             # this is a window with path '.'
819             my $interp = shift;
820            
821            
822             return $W{mainwindow}->{"$interp"};
823             }
824             sub tkinit {
825             my $interp = Tcl::pTk->new(@_);
826             $interp->mainwindow;
827             }
828            
829             sub MainWindow {
830             my $interp = Tcl::pTk->new(@_);
831            
832             # Load Tile Widgets, if the tcl version is > 8.5
833             my $patchlevel = $interp->icall('info', 'patchlevel');
834             my (@patchElems) = split('\.', $patchlevel);
835             my $versionNumber = $patchElems[0] + $patchElems[1]/1000 + $patchElems[2]/100e3; # convert version to number
836             if( $versionNumber >= 8.005 ){
837             require Tcl::pTk::Tile;
838             Tcl::pTk::Tile::_declareTileWidgets($interp);
839             }
840            
841             # Load palette commands, so $interp->invoke can be used with them later, for speed.
842             $interp->call('auto_load', 'tk_setPalette');
843            
844            
845             # Declare auto-widgets, so subclasses of auto-created widgets will work correctly.
846             Tcl::pTk::Widget::declareAutoWidget($interp);
847            
848            
849             $interp->mainwindow;
850             }
851            
852            
853             ## Front-End for fileevent that can be called using Tcl::pTk->fileevent, instead of the normal
854             # $widget->filevent syntax. This is provided for compatibility with perl/tk
855             #
856             sub fileevent{
857             my $firstArg = shift;
858             my $int = ( ref($firstArg) ? $firstArg : $tkinterp ); # Get default interp, unless supplied
859             my $mw = $int->mainwindow(); # Get the mainwindow for this interpreter
860            
861             # Call the normal fileevent
862             $mw->fileevent(@_);
863             }
864            
865             sub MainLoop {
866             # This perl-based mainloop differs from Tk_MainLoop in that it
867             # relies on the traced deletion of '.' instead of using the
868             # Tk_GetNumMainWindows C API.
869             # This could optionally be implemented with 'vwait' on a specially
870             # named variable that gets set when '.' is destroyed.
871             unless ($inMainLoop){ # Don't recursivly enter into a mainloop
872             local $inMainLoop = 1;
873             my $int = (ref $_[0]?shift:$tkinterp);
874             my $mainwindow = $W{mainwindow};
875             while ( %$mainwindow ) { # Keep calling DoOneEvent until all mainwindows go away
876             $int->DoOneEvent(0);
877             }
878             }
879             }
880            
881             # timeofday function for compatibility with Tk::timeofday
882             sub timeofday {
883             # This perl-based mainloop differs from Tk_MainLoop in that it
884             # relies on the traced deletion of '.' instead of using the
885             # Tk_GetNumMainWindows C API.
886             # This could optionally be implemented with 'vwait' on a specially
887             # named variable that gets set when '.' is destroyed.
888             my $int = (ref $_[0]?shift:$tkinterp);
889             my $t = $int->invoke("clock", "microseconds");
890             $t = $t/1e6;
891             }
892            
893            
894             # DoOneEvent for compatibility with perl/tk
895             sub DoOneEvent{
896             my $int = (ref $_[0]?shift:$tkinterp);
897             my $flags = shift;
898             $int->Tcl::DoOneEvent($flags);
899             }
900            
901             # After wrapper for compatibility with perl/tk (So that Tcl::pTk->after(delay) calls work
902             sub after{
903             my $int = shift;
904             $int = (ref($int) ? $int : $tkinterp ); # if interpreter not supplied use $tkinterp
905             my $ms = shift;
906             my $callback = shift;
907            
908             $ms = int($ms) if( $ms =~ /\d/ ); # Make into an integer to keep tk from complaining
909            
910             if( defined($callback)){
911             # Turn into callback, if not one already
912             unless( blessed($callback) and $callback->isa('Tcl::pTk::Callback')){
913             $callback = Tcl::pTk::Callback->new($callback);
914             }
915            
916             my $sub = sub{ $callback->Call()};
917             #print "Tcl::pTk::after: setting after on $sub\n";
918             my $ret = $int->call('after', $ms, $sub );
919             return $int->declare_widget($ret);
920             }
921             else{ # No Callback defined, just do a sleep
922             return $int->call('after', $ms );
923             }
924            
925             return($int->call('after', $ms));
926             }
927            
928            
929             # create_widget Method
930             # This is used as a front-end to the declare_widget method, so that -command and -variable configuration
931             # options supplied at widget-creation will be properly stored as Tcl::pTk::Callback objects (for perltk
932             # compatibility).
933             # This is done by issuing the -command or -variable type option after widget creation, where the callback object can be
934             # stored with the widget
935             sub create_widget{
936             my $int = shift; # Interperter
937             my $parent = shift; # Parent widget
938             my $id = shift; # unique id for the new widget
939             my $ttktype = shift; # Name of widget, in tcl/tk
940             my $widget_class = shift || 'Tcl::pTk::Widget';
941            
942             my @args = @_;
943            
944             my @filteredArgs; # args, filtered of any -command type options
945             my @commandOptions; # any command options needed to be issued after widget creation.
946            
947             # Go thru each arg and look for callback (i.e -command ) args
948             my $lastArg;
949             foreach my $arg(@args){
950            
951             if( defined($lastArg) && !ref($lastArg) && ( $lastArg =~ /^-\w+/ ) ){
952             if( $lastArg =~ /command|cmd$/ && defined($arg) ) { # Check for last arg something like -command
953            
954             #print "Found command arg $lastArg => $arg\n";
955            
956             # Save this option for issuing after widget creation
957             push @commandOptions, $lastArg, $arg;
958            
959             # Remove the lastArg from the current arg queue, since we will be handling
960             # it using @commandOptions
961             pop @filteredArgs;
962            
963             $lastArg = undef;
964             next;
965             }
966             if( $lastArg =~ /variable$/ ){ # Check for last arg something like -textvariable
967             # Save this option for issuing after widget creation
968             push @commandOptions, $lastArg, $arg;
969            
970             # Remove the lastArg from the current arg queue, since we will be handling
971             # it using @commandOptions
972             pop @filteredArgs;
973            
974             $lastArg = undef;
975             next;
976             }
977            
978             }
979            
980             $lastArg = $arg;
981            
982             push @filteredArgs, $arg;
983             }
984            
985             # Make the normal declare_widget call
986             my $widget = $int->declare_widget($parent->call($ttktype, $id, @filteredArgs), $widget_class);
987            
988             # Make configure call for any left-over commands
989             $widget->configure(@commandOptions) if(@commandOptions);
990            
991             return $widget;
992             }
993            
994            
995             #
996             # declare_widget, method of interpreter object
997             # args:
998             # - a path of existing Tcl/Tk widget to declare its existance in Tcl::pTk
999             # - (optionally) package name where this widget will be declared, default
1000             # is 'Tcl::pTk::Widget', but could be 'Tcl::pTk::somewidget'
1001             sub declare_widget {
1002             my $int = shift;
1003             my $path = shift;
1004             my $widget_class = shift || 'Tcl::pTk::Widget';
1005             # JH: This is all SOOO wrong, but works for the simple case.
1006             # Issues that need to be addressed:
1007             # 1. You can create multiple interpreters, each containing identical
1008             # pathnames. This var should be better scoped.
1009             # VK: mostly resolved, such interpreters with pathnames allowed now
1010             # 2. There is NO cleanup going on. We should somehow detect widget
1011             # destruction (trace add command delete ... in 8.4) and interp
1012             # destruction to clean up package variables.
1013             #my $id = $path=~/^\./ ? $int->invoke('winfo','id',$path) : $path;
1014             $int->invoke('trace', 'add', 'command', $path, 'delete', "::perl::w_del $path")
1015             if ( WIDGET_CLEANUP && $path !~ /\#/); # don't trace for widgets like 'after#0'
1016             my $id = $path;
1017             my $w = bless({ winID => $id}, $widget_class);
1018             Carp::confess("id is not found\n") if( !defined($id));
1019             $Wpath->{$id} = $path; # widget pathname
1020             $Wint->{$id} = $int; # Tcl interpreter
1021             $W{RPATH}->{$path} = $w;
1022            
1023            
1024             return $w;
1025             }
1026            
1027             sub widget_deletion_watcher {
1028             my (undef,$int,undef,$path) = @_;
1029             #print STDERR "[D:$path]\n";
1030            
1031             # Call the _OnDestroy method on the widget to perform cleanup on it
1032             my $w = $W{RPATH}->{$path};
1033             #print STDERR "Calling _Destroyed on $w, Ind = ".$Idelete++."\n";
1034             $w->_Destroyed();
1035            
1036             $int->delete_widget_refs($path);
1037            
1038             delete $W{RPATH}->{$path};
1039             }
1040            
1041             ###############################################
1042             # Overriden delete_ref
1043             # Instead of immediately deleting a scalar or code ref in Tcl-land,
1044             # queue the ref to be deleted in an after-idle call.
1045             # This is done, rather than deleting immediately, because an immediate delete
1046             # before a widget is completely destroyed can causes Tcl-crashes.
1047             sub delete_ref {
1048             my $interp = shift;
1049             my $rname = shift;
1050             my $ref = $interp->return_ref($rname);
1051             push @cleanup_refs, $rname;
1052            
1053             # Create an after-idle call to delete refs, if the cleanup queue is bigger
1054             # than the threshold
1055             if( !$cleanupPending and scalar(@cleanup_refs) > $cleanup_queue_maxsize ){
1056             #print STDERR "Calling after idle cleanup on ".join(", ", @cleanup_refs)."\n";
1057             $cleanupPending = 1; # Setup flag so we don't call the after idle multiple times
1058             $interp->call('after', 'idle', "::perl::w_cleanup");
1059             }
1060             return $ref;
1061             }
1062            
1063            
1064             # Sub to cleanup any que-ed commands and variables in
1065             # @cleanup_refs. This usually called from an after-idle procedure
1066             sub widget_cleanup {
1067             my (undef,$int,undef,$path) = @_;
1068            
1069             my @deleteList = @cleanup_refs;
1070            
1071             # Go thru each list and delete
1072             foreach my $rname(@deleteList){
1073             #print "Widget_Cleanup deleting $rname\n";
1074            
1075             $int->_delete_ref($rname);
1076             }
1077            
1078             # Zero-out cleanup_refs
1079             @cleanup_refs = ();
1080             $cleanupPending = 0; # Reset cleanup flag for next time
1081            
1082             }
1083            
1084             # widget_data return anonymous hash that could be used to hold any
1085             # user-specific data
1086             sub widget_data {
1087             my $int = shift;
1088             my $path = shift;
1089             $Wdata->{$path} ||= {};
1090             return $Wdata->{$path};
1091             }
1092            
1093             # subroutine awidget used to create [a]ny [widget]. Nothing complicated here,
1094             # mainly needed for keeping track of this new widget and blessing it to right
1095             # package
1096             sub awidget {
1097             my $int = (ref $_[0]?shift:$tkinterp);
1098             my $wclass = shift;
1099             # Following is a suboptimal way of autoloading, there should exist a way
1100             # to Improve it.
1101             my $sub = sub {
1102             my $int = (ref $_[0]?shift:$tkinterp);
1103             my ($path) = $int->call($wclass, @_);
1104             return $int->declare_widget($path);
1105             };
1106             unless ($wclass=~/^\w+$/) {
1107             die "widget name '$wclass' contains not allowed characters";
1108             }
1109             # create appropriate method ...
1110             no strict 'refs';
1111             *{"Tcl::pTk::$wclass"} = $sub;
1112             # ... and call it (if required)
1113             if ($#_>-1) {
1114             return $sub->($int,@_);
1115             }
1116             }
1117             sub widget($@) {
1118             my $int = (ref $_[0]?shift:$tkinterp);
1119             my $wpath = shift;
1120             my $wtype = shift || 'Tcl::pTk::Widget';
1121             if (exists $W{RPATH}->{$wpath}) {
1122             return $W{RPATH}->{$wpath};
1123             }
1124             unless ($wtype=~/^(?:Tcl::pTk)/) {
1125             Tcl::pTk::Widget::create_widget_package($wtype);
1126             $wtype = "Tcl::pTk::$wtype";
1127             }
1128             #if ($wtype eq 'Tcl::pTk::Widget') {
1129             # require Carp;
1130             # Carp::cluck("using \"widget\" without widget type is strongly discouraged");
1131             #}
1132             # We could ask Tcl about it by invoking
1133             # my @res = $int->Eval("winfo exists $wpath");
1134             # but we don't do it, as long as we allow any widget paths to
1135             # be used by user.
1136             my $w = $int->declare_widget($wpath,$wtype);
1137             return $w;
1138             }
1139            
1140             sub Exists {
1141             my $wid = shift;
1142             return 0 unless defined($wid);
1143             if (blessed($wid) && $wid->isa('Tcl::pTk::Widget') ) {
1144             my $wp = $wid->path;
1145             my $interp = $wid->interp;
1146             return 0 unless( defined $interp); # Takes care of some issues during global destruction
1147             return $interp->icall('winfo','exists',$wp);
1148             }
1149             return eval{$tkinterp->icall('winfo','exists',$wid)};
1150             }
1151            
1152             sub widgets {
1153             \%W;
1154             }
1155            
1156             sub pkg_require {
1157             # Do Tcl package require with optional version, cache result.
1158             my $int = shift;
1159             my $pkg = shift;
1160             my $ver = shift;
1161            
1162             my $id = "$int$pkg"; # to made interpreter-wise, do stringification of $int
1163            
1164             return $preloaded_tk{$id} if $preloaded_tk{$id};
1165            
1166             my @args = ("package", "require", $pkg);
1167             push(@args, $ver) if defined($ver);
1168             eval { $preloaded_tk{$id} = $int->icall(@args); };
1169             if ($@) {
1170             # Don't cache failures, as the package may become available by
1171             # changing auto_path and such.
1172             return;
1173             }
1174             return $preloaded_tk{$id};
1175             }
1176            
1177             sub need_tk {
1178             # DEPRECATED: Use pkg_require and call instead.
1179             my $int = shift;
1180             my $pkg = shift;
1181             my $cmd = shift || '';
1182             warn "DEPRECATED CALL: need_tk($pkg, $cmd), use pkg_require\n";
1183             if ($pkg eq 'ptk-Table') {
1184             require Tcl::pTk::Table;
1185             }
1186             else {
1187             # Only require the actual package once
1188             my $ver = $int->pkg_require($pkg);
1189             return 0 if !defined($ver);
1190             $int->Eval($cmd) if $cmd;
1191             }
1192             return 1;
1193             }
1194            
1195            
1196            
1197             # subroutine findINC copied from perlTk/Tk.pm
1198             sub findINC {
1199             my $file = join('/',@_); # Normal location
1200             my $fileImage = join('/', $_[0], 'images', $_[1]); # alternate location in the 'images' directory
1201             my $dir;
1202             $file =~ s,::,/,g;
1203             $fileImage =~ s,::,/,g;
1204             foreach $dir (@INC) {
1205             my $path;
1206            
1207             # check for normal location and 'images' location of the file
1208             return $path if (-e ($path = "$dir/$file") );
1209             return $path if (-e ($path = "$dir/$fileImage") );
1210            
1211             }
1212             return undef;
1213             }
1214            
1215            
1216            
1217             # sub Declare is just a dispatcher into Tcl::pTk::Widget method
1218             sub Declare {
1219             Tcl::pTk::Widget::Declare(undef,@_[1..$#_]);
1220             }
1221            
1222            
1223             #
1224             # AUTOLOAD method for Tcl::pTk interpreter object, which will bring into
1225             # existance interpreter methods
1226             sub AUTOLOAD {
1227             my $int = shift;
1228             my ($method,$package) = $Tcl::pTk::AUTOLOAD;
1229            
1230             # If this is the Tcl::pTk::Error routine,
1231             # Call the standard Autoloader::AUTOLOAD to
1232             # load our Error routine that has been autosplit to a separate file
1233             # (i.e. appears after the _END_).
1234             # Autoloading the Error routine keeps from getting subroutine redefined warnings
1235             # when the user supplies their own Error routine or Tcl::pTk::ErrorDialog is used.
1236             if( $method =~ /Tcl::pTk::Error/ ){
1237             if( defined( $Tcl::pTk::TkHijack::translateList ) ){
1238             #print "TkHijack is loaded\n";
1239             # If TkHijack is loaded and the user has define their own
1240             # Tk::Error, call that:
1241             if( defined(&Tk::Error)){
1242             #print "Tk::Error has been defined\n";
1243             *Tcl::pTk::Error = \&Tk::Error;
1244             return $int->Tcl::pTk::Error(@_);
1245            
1246             }
1247             }
1248             $AutoLoader::AUTOLOAD = $method;
1249             unshift @_, $int; # Put arg back on stack like AUTOLOAD expects it
1250             goto &AutoLoader::AUTOLOAD;
1251             }
1252            
1253             # Normal handling follows
1254             my $method0;
1255             for ($method) {
1256             s/^(Tcl::pTk::)//
1257             or Carp::confess "weird inheritance ($method)";
1258             $package = $1;
1259             $method0 = $method;
1260             s/(?
1261             s/(?
1262             }
1263            
1264             # if someone calls $interp->_method(...) then it is considered as faster
1265             # version of method, similar to calling $interp->method(...) but via
1266             # 'invoke' instead of 'call', thus faster
1267             my $fast = '';
1268             $method =~ s/^_// and do {
1269             $fast='_';
1270             if (exists $::Tcl::pTk::{$method}) {
1271             no strict 'refs';
1272             *{"::Tcl::pTk::_$method"} = *{"::Tcl::pTk::$method"};
1273             return $int->$method(@_);
1274             }
1275             };
1276            
1277             # search for right corresponding Tcl/Tk method, and create it afterwards
1278             # (so no consequent AUTOLOAD will happen)
1279            
1280             # Check to see if it is a camelCase method. If so, split it apart.
1281             # code below will always create subroutine that calls a method.
1282             # This could be changed to create only known methods and generate error
1283             # if method is, for example, misspelled.
1284             # so following check will be like
1285             # if (exists $knows_method_names{$method}) {...}
1286             my $sub;
1287             if ($method =~ /^([a-z]+)([A-Z][a-z]+)$/) {
1288             my ($meth, $submeth) = ($1, lcfirst($2));
1289             # break into $method $submethod and call
1290             $sub = $fast ? sub {
1291             my $int = shift;
1292             $int->invoke($meth, $submeth, @_);
1293             } : sub {
1294             my $int = shift;
1295             $int->call($meth, $submeth, @_);
1296             };
1297             }
1298             else {
1299             # Default case, call as method of $int
1300             $sub = $fast ? sub {
1301             my $int = shift;
1302             $int->invoke($method, @_);
1303             } : sub {
1304             my $int = shift;
1305             $int->call($method, @_);
1306             };
1307             }
1308             no strict 'refs';
1309             *{"$package$fast$method0"} = $sub;
1310             Sub::Name::subname("$package$fast$method0", $sub) if( $Tcl::pTk::DEBUG);
1311             return $sub->($int,@_);
1312             }
1313            
1314             # Sub to support the "Ev('x'), Ev('y'), etc" syntax that perltk uses to supply event information
1315             # to bind callbacks. This sub-name is exported with the other perltk subs (like MainLoop, etc).
1316             sub Ev {
1317             my @events = @_;
1318             return bless \@events, "Tcl::pTk::Ev";
1319             }
1320            
1321             # Tcl::pTk::break, used to break out of event bindings (i.e. don't process anymore bind subs after break is called).
1322             # This is handled by the wrapper tcl code setup in Tcl::pTk::bind
1323             sub break
1324             {
1325             # Check to see if we are being called from Tcl::pTk::Callback, if so, then this is a valid 'break' call
1326             # and we will die with _TK_BREAK_
1327             my @callInfo;
1328             my $index = 0;
1329             my $callback; # Flag = 1 if this is a callback
1330             while (@callInfo = caller($index)){
1331             #print STDERR "Break Caller = ".join(", ", @callInfo)."\n";
1332             if( $callInfo[3] eq 'Tcl::pTk::Callback::BindCall'){
1333             $callback = 1;
1334             }
1335             $index++;
1336             }
1337            
1338             die "_TK_BREAK_\n" if($callback);
1339            
1340             }
1341            
1342             # Wrappers for the Event Flag subs in Tcl (for compatiblity with perl/tk code
1343             sub DONT_WAIT{ Tcl::DONT_WAIT()};
1344             sub WINDOW_EVENTS{ Tcl::WINDOW_EVENTS()};
1345             sub FILE_EVENTS{ Tcl::FILE_EVENTS()};
1346             sub TIMER_EVENTS{ Tcl::TIMER_EVENTS()};
1347             sub IDLE_EVENTS{ Tcl::IDLE_EVENTS()};
1348             sub ALL_EVENTS{ Tcl::ALL_EVENTS()};
1349            
1350             # Wrappers for the Tk color functions (for compatibility with perl/tk
1351             sub NORMAL_BG{
1352             if($^O eq 'cygwin' || $^O =~ /win32/ ){
1353             return 'systembuttonface';
1354             }
1355             elsif( $^O =~ /darwin/i ){ # MacOS
1356             return 'systemWindowBody';
1357             }
1358             else{ # Must be unix
1359             return '#d9d9d9';
1360             }
1361             }
1362            
1363             sub ACTIVE_BG{
1364             if($^O eq 'cygwin' || $^O =~ /win32/ ){
1365             return 'systembuttonface';
1366             }
1367             elsif( $^O =~ /darwin/i ){ # MacOS
1368             return 'systemButtonFacePressed';
1369             }
1370             else{ # Must be unix
1371             return '#ececec';
1372             }
1373             }
1374            
1375             sub SELECT_BG{
1376             if($^O eq 'cygwin' || $^O =~ /win32/ ){
1377             return 'SystemHighlight';
1378             }
1379             elsif( $^O =~ /darwin/i ){ # MacOS
1380             return 'systemHighlightSecondary';
1381             }
1382             else{ # Must be unix
1383             return '#c3c3c3';
1384             }
1385             }
1386            
1387             # Background error routine that calls Tcl::pTk::Error, similar to perltk calling Tk::Error
1388             # Upon Tcl interp creation, this routine is created in Tcl (called the special name bgerror) so that this Tcl::pTk:;bgerror
1389             # will be called for background errors
1390             sub bgerror{
1391             my ($what,$obj, $sub, $message) = @_;
1392            
1393             # Note: what is undefined, $obj is the current interp, sub is the name of the Tcl error handler (e.g. bgerror)
1394             #
1395             #print "what = $what, obj = $obj, sub = $sub, message = $message\n";
1396             # Variables for creating a "sanitized" stack trace
1397             # (i.e. stack trace that won't include a lot of Tcl::pTk internal info)
1398            
1399            
1400             my $mw; # Mainwindow of the current interpreter
1401             $mw = $obj->mainwindow if( ref( $obj ));
1402            
1403            
1404             my ($stackMessage, $shortLocation, $errorInfo);
1405             local $Carp::Internal{'Tcl::pTk::Callback'} = 1;
1406             local $Carp::Internal{'Tcl::pTk::Widget'} = 1;
1407             local $Carp::Internal{'Tcl'} = 1;
1408             $stackMessage = Carp::longmess();
1409             $shortLocation = Carp::shortmess();
1410             $errorInfo = $obj->Eval('set ::errorInfo');
1411            
1412             # For compatibility with perl/tk, build the error message and stack info as an array
1413             my @stack = ("Stack Trace:", split(/\n/, $stackMessage) );
1414             my $errorMess = $errorInfo . "\n\n Error Started$shortLocation\n";
1415             $mw->Tcl::pTk::Error( $errorMess, @stack); # Call Tcl::pTk::Error like Tk::Error would get called
1416             }
1417            
1418             #############################################################################################
1419             # Methods in Tcl.pm version 1.02 that are now implemented here
1420             # Tcl.pm versions > 1.02 broke compatibility with Tcl::pTk, so we implement our
1421             # own functions here that previously were provided with Tcl.pm <= 1.02
1422             #############################################################################################
1423             ###############################################
1424             # Overriden delete_widget_refs
1425             # This is implemented in Tcl::pTk.pm because for versions of Tcl.pm > 1.02,
1426             # this method is not supported, so we implement it ourselves here.
1427             sub delete_widget_refs {
1428             my $interp = shift;
1429             my $wpath = shift;
1430             for (keys %{$widget_refs{$wpath}}) {
1431             #print STDERR "del:$wpath($_)\n";
1432             delete $widget_refs{$wpath}->{$_};
1433             $interp->delete_ref($_);
1434             }
1435             }
1436            
1437             # Original delete_ref from Tcl.pm 1.02
1438             sub _delete_ref {
1439             my $interp = shift;
1440             my $rname = shift;
1441             my $ref = delete $anon_refs{$rname};
1442             if (ref($ref) eq 'CODE') {
1443             $interp->DeleteCommand($rname);
1444             }
1445             else {
1446             $interp->UnsetVar($rname); #TODO: will this delete variable in Tcl?
1447             untie $$ref;
1448             }
1449             return $ref;
1450             }
1451             ###############################################
1452             # Overriden _current_refs_widget
1453             # This is implemented in Tcl::pTk.pm because for versions of Tcl.pm > 1.02,
1454             # this method is not supported, so we implement it ourselves here.
1455             sub _current_refs_widget {$current_widget=shift}
1456            
1457             # create_tcl_sub will create TCL sub that will invoke perl anonymous sub
1458             # If $events variable is specified then special processing will be
1459             # performed to provide needed '%' variables.
1460             # If $tclname is specified then procedure will have namely that name,
1461             # otherwise it will have machine-readable name.
1462             # Returns tcl script suitable for using in tcl events.
1463             sub create_tcl_sub {
1464             my ($interp,$sub,$events,$tclname) = @_;
1465             unless ($tclname) {
1466             # stringify sub, becomes "CODE(0x######)" in ::perl namespace
1467             $tclname = "::perl::$sub";
1468             }
1469             unless (exists $anon_refs{$tclname}) {
1470             $anon_refs{$tclname} = $sub;
1471             $interp->CreateCommand($tclname, $sub, undef, undef, 1);
1472             }
1473             if ($events) {
1474             # Add any %-substitutions to callback
1475             $tclname = "$tclname " . join(' ', @{$events});
1476             }
1477             return $tclname;
1478             }
1479             ############################################################################
1480             sub return_ref {
1481             my $interp = shift;
1482             my $rname = shift;
1483             return $anon_refs{$rname};
1484             }
1485            
1486             # Subroutine "call" preprocess the arguments for special cases
1487             # and then calls "icall" (implemented in Tcl.xs), which invokes
1488             # the command in Tcl.
1489             sub call {
1490             my $interp = shift;
1491             my @args = @_;
1492            
1493             # Process arguments looking for special cases
1494             for (my $argcnt=0; $argcnt<=$#args; $argcnt++) {
1495             my $arg = $args[$argcnt];
1496             my $ref = ref($arg);
1497             next unless $ref;
1498             if ($ref eq 'CODE') {
1499             # We have been passed something like \&subroutine
1500             # Create a proc in Tcl that invokes this subroutine (no args)
1501             $args[$argcnt] = $interp->create_tcl_sub($arg);
1502             $widget_refs{$current_widget}->{$args[$argcnt]}++;
1503             }
1504             elsif ($ref =~ /^Tcl::Tk::Widget\b/) {
1505             # We have been passed a widget reference.
1506             # Convert to its Tk pathname (eg, .top1.fr1.btn2)
1507             $args[$argcnt] = $arg->path;
1508             $current_widget = $args[$argcnt] if $argcnt==0;
1509             }
1510             elsif ($ref eq 'SCALAR') {
1511             # We have been passed something like \$scalar
1512             # Create a tied variable between Tcl and Perl.
1513            
1514             # stringify scalar ref, create in ::perl namespace on Tcl side
1515             # This will be SCALAR(0xXXXXXX) - leave it to become part of a
1516             # Tcl array.
1517             my $nm = "::perl::$arg";
1518             #$nm =~ s/\W/_/g; # remove () from stringified name
1519             unless (exists $anon_refs{$nm}) {
1520             $widget_refs{$current_widget}->{$nm}++;
1521             $anon_refs{$nm} = $arg;
1522             my $s = $$arg;
1523             tie $$arg, 'Tcl::Var', $interp, $nm;
1524             $s = '' unless defined $s;
1525             $$arg = $s;
1526             }
1527             $args[$argcnt] = $nm; # ... and substitute its name
1528             }
1529             elsif ($ref eq 'HASH') {
1530             # We have been passed something like \%hash
1531             # Create a tied variable between Tcl and Perl.
1532            
1533             # stringify hash ref, create in ::perl namespace on Tcl side
1534             # This will be HASH(0xXXXXXX) - leave it to become part of a
1535             # Tcl array.
1536             my $nm = $arg;
1537             $nm =~ s/\W/_/g; # remove () from stringified name
1538             $nm = "::perl::$nm";
1539             unless (exists $anon_refs{$nm}) {
1540             $widget_refs{$current_widget}->{$nm}++;
1541             $anon_refs{$nm} = $arg;
1542             my %s = %$arg;
1543             tie %$arg, 'Tcl::Var', $interp, $nm;
1544             %$arg = %s;
1545             }
1546             $args[$argcnt] = $nm; # ... and substitute its name
1547             }
1548             elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') {
1549             # We have been passed something like [\&subroutine, $arg1, ...]
1550             # Create a proc in Tcl that invokes this subroutine with args
1551             my $events;
1552             # Look for Tcl::Ev objects as the first arg - these must be
1553             # passed through for Tcl to evaluate. Used primarily for %-subs
1554             # This could check for any arg ref being Tcl::Ev obj, but it
1555             # currently doesn't.
1556             if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') {
1557             $events = splice(@$arg, 1, 1);
1558             }
1559             $args[$argcnt] =
1560             $interp->create_tcl_sub(sub {
1561             $arg->[0]->(@_, @$arg[1..$#$arg]);
1562             }, $events);
1563             }
1564             elsif ($ref eq 'ARRAY' && ref($arg->[0]) =~ /^Tcl::Tk::Widget\b/) {
1565             # We have been passed [$Tcl_Tk_widget, 'method name', ...]
1566             # Create a proc in Tcl that invokes said method with args
1567             my $events;
1568             # Look for Tcl::Ev objects as the first arg - these must be
1569             # passed through for Tcl to evaluate. Used primarily for %-subs
1570             # This could check for any arg ref being Tcl::Ev obj, but it
1571             # currently doesn't.
1572             if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') {
1573             $events = splice(@$arg, 1, 1);
1574             }
1575             my $wid = $arg->[0];
1576             my $method_name = $arg->[1];
1577             $args[$argcnt] =
1578             $interp->create_tcl_sub(sub {
1579             $wid->$method_name(@$arg[2..$#$arg]);
1580             }, $events);
1581             }
1582             elsif (ref($arg) eq 'REF' and ref($$arg) eq 'SCALAR') {
1583             # this is a very special shortcut: if we see construct like \\"xy"
1584             # then place proper Tcl::Ev(...) for easier access
1585             my $events = [map {"%$_"} split '', $$$arg];
1586             if (ref($args[$argcnt+1]) eq 'ARRAY' &&
1587             ref($args[$argcnt+1]->[0]) eq 'CODE') {
1588             $arg = $args[$argcnt+1];
1589             $args[$argcnt] =
1590             $interp->create_tcl_sub(sub {
1591             $arg->[0]->(@_, @$arg[1..$#$arg]);
1592             }, $events);
1593             }
1594             elsif (ref($args[$argcnt+1]) eq 'CODE') {
1595             $args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events);
1596             }
1597             else {
1598             warn "not CODE/ARRAY expected after description of event fields";
1599             }
1600             splice @args, $argcnt+1, 1;
1601             }
1602             }
1603             # Done with special var processing. The only processing that icall
1604             # will do with the args is efficient conversion of SV to Tcl_Obj.
1605             # A SvIV will become a Tcl_IntObj, ARRAY refs will become Tcl_ListObjs,
1606             # and so on. The return result from icall will do the opposite,
1607             # converting a Tcl_Obj to an SV.
1608             if (!$Tcl::STACK_TRACE) {
1609             return $interp->icall(@args);
1610             }
1611             elsif (wantarray) {
1612             my @res;
1613             eval { @res = $interp->icall(@args); };
1614             if ($@) {
1615             require Carp;
1616             Carp::confess ("Tcl error '$@' while invoking array result call:\n" .
1617             "\t\"@args\"");
1618             }
1619             return @res;
1620             } else {
1621             my $res;
1622             eval { $res = $interp->icall(@args); };
1623             if ($@) {
1624             require Carp;
1625             Carp::confess ("Tcl error '$@' while invoking scalar result call:\n" .
1626             "\t\"@args\"");
1627             }
1628             return $res;
1629             }
1630             }
1631            
1632             #############################################################################################
1633             # End of Re-implementation of Methods in Tcl.pm version 1.02
1634             #############################################################################################
1635            
1636            
1637            
1638             1;
1639            
1640             __END__