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, C , C, C and so
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__