summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Adjuster.pm436
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/After.pm104
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Animation.pm178
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Balloon.pm621
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Bitmap.pm10
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm510
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Button.pm148
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Camel.xpm41
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Canvas.pm1436
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm42
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Clipboard.pm122
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/CmdLine.pm954
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm58
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm761
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Compound.pm40
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Config.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Configure.pm69
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Credits7
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Derived.pm512
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Dialog.pm70
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DialogBox.pm135
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DirTree.pm252
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Dirlist.pm113
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop.pm332
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm59
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm61
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm110
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm34
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm200
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm107
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm145
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm159
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DropSite.pm257
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm46
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/English.pm307
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Entry.pm615
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm125
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Event.pm13
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Event/IO.pm132
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/FBox.pm1043
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/FileSelect.pm578
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm109
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Font.pm163
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Frame.pm378
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/HList.pm680
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/IO.pm182
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/IconList.pm712
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Image.pm74
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm38
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/JPEG.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/LabEntry.pm31
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/LabFrame.pm138
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/LabRadio.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Label.pm21
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Labelframe.pm16
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Listbox.pm910
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MMtry.pm54
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MMutil.pm600
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MainWindow.pm213
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm292
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Menu.pm1145
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm180
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Menubar.pm15
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Menubutton.pm398
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Message.pm20
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/NBFrame.pm20
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/NoteBook.pm452
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm130
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/PNG.pm43
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Pane.pm544
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm221
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Photo.pm22
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Pixmap.pm19
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Pretty.pm93
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm498
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/README.Adjust77
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ROText.pm43
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm45
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Region.pm182
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Reindex.pm225
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm13
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm13
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Scale.pm278
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm429
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Spinbox.pm115
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Stats.pm26
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Submethods.pm46
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TList.pm416
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Table.pm598
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Text.pm1653
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm46
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextEdit.pm509
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextList.pm985
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextUndo.pm1022
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Tiler.pm203
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TixGrid.pm1597
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Tk.xbm44
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Tk.xpm41
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TkXSUB.def62
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Toplevel.pm211
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Trace.pm405
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Tree.pm228
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Widget.pm1510
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Wm.pm174
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X.pm398
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/X.h677
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h79
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h60
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h1214
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h855
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h79
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/keysym.h39
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h1169
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11/license.terms39
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/X11Font.pm184
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Xcamel.gifbin0 -> 4193 bytes
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Xlib.pm15
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Xrm.pm11
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/act_folder.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/act_folder.xpm22
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/anim.gifbin0 -> 2533 bytes
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/balArrow.xbm4
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm6
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/file.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/file.xpm18
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/folder.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/folder.xpm21
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/icon.gifbin0 -> 1924 bytes
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/install.pm37
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/license.terms35
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/openfile.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/openfolder.xbm5
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/openfolder.xpm21
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/prolog.ps284
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/reindex.pl33
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/srcfile.xpm18
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/textfile.xpm18
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tkGlue.def130
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tkGlue.h79
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tkGlue.m74
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tkGlue.t70
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h14
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/tranicon.gifbin0 -> 1718 bytes
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/typemap96
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/vtab.def90
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/widgets.pm21
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/win.xbm6
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/winfolder.xpm39
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/wintext.xpm42
152 files changed, 36759 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
new file mode 100644
index 00000000000..382ec6db6f9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
@@ -0,0 +1,436 @@
+package Tk::Adjuster;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $
+
+use base qw(Tk::Frame);
+
+# We cannot do this :
+
+# Construct Tk::Widget 'packAdjust';
+
+# because if managed object is Derived (e.g. a Scrolled) then our 'new'
+# will be delegated and hierachy gets turned inside-out
+# So packAdjust is autoloaded in Widget.pm
+
+
+Construct Tk::Widget qw(Adjuster);
+
+{package Tk::Adjuster::Item;
+
+use strict;
+use base qw(Tk::Frame);
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<1>',['BDown', 1]);
+ $mw->bind($class,'<Shift-1>',['BDown', 0]);
+ $mw->bind($class,'<B1-Motion>',['Motion',1]);
+ $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
+ $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
+ return $class;
+}
+
+sub BDown
+{
+ my($w, $delay_mask) = @_;
+ $w->{'start_x'} = $w->XEvent->x;
+ $w->{'start_y'} = $w->XEvent->y;
+ my $adj = $w->Parent;
+ delete $adj->{'lin_info'};
+ my $delay = $delay_mask && $adj->cget('-delay');
+ if ($delay)
+ {
+ $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0);
+ }
+}
+
+sub Motion
+{
+ my($w, $delay_mask) = @_;
+ my $ev = $w->XEvent;
+ my $adj = $w->Parent;
+
+ my $delay = $delay_mask && $adj->cget('-delay');
+ if ($adj->vert)
+ {
+ my $dx = $ev->x - $w->{'start_x'};
+ $delay ? $adj->delta_width_bar($dx) : $adj->delta_width($dx);
+ }
+ else
+ {
+ my $dy = $ev->y - $w->{'start_y'};
+ $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy);
+ }
+}
+
+}
+
+
+
+sub packAfter
+{
+ my ($w,$s,%args) = @_;
+ my $side = $args{'-side'} ? $args{'-side'} : 'top';
+ $w->configure(-side => $side, -widget => $s);
+ $w->packed($s, %args);
+}
+
+sub packForget
+{
+ my ($w,$forget_slave) = @_;
+ $w->Tk::Widget::packForget;
+ $w->slave->packForget if $forget_slave;
+}
+
+# Called by Tk::Widget::packAdjust. It was here before packAfter was added
+sub packed
+{
+ my ($w,$s,%args) = @_;
+ delete $args{'-before'};
+ delete $args{'-in'};
+ $args{'-expand'} = 0;
+ $args{'-after'} = $s;
+ $args{'-fill'} = (($w->vert) ? 'y' : 'x');
+ $w->pack(%args);
+}
+
+sub gridded
+{
+ my ($w,$s,%args) = @_;
+ # delete $args{'-before'};
+ # $args{'-expand'} = 0;
+ # $args{'-after'} = $s;
+ # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
+ $w->grid(%args);
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>','SizeChange');
+ $mw->bind($class,'<Unmap>','Restore');
+ $mw->bind($class,'<Map>','Mapped');
+ return $class;
+}
+
+sub SizeChange
+{
+ my $w = shift;
+ # reqwidth/height of Adjuster is stored here. If it is partially pushed out
+ # of the window, then $w->width/height returns that of the visible part.
+ if ($w->vert)
+ {
+ my $sx = ($w->Width - $w->{'sep'}->Width)/2;
+ $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
+ $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1);
+ $w->configure(-width => $w->{'but'}->ReqWidth);
+ $w->{'reqwidth'} = $w->reqwidth;
+ }
+ else
+ {
+ my $sy = ($w->Height - $w->{'sep'}->Height)/2;
+ $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
+ $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1);
+ $w->configure(-height => $w->{'but'}->ReqHeight);
+ $w->{'reqheight'} = $w->reqheight;
+ }
+ # Turn off geometry propagation in the slave. Do only if necessary, as this
+ # causes repacking.
+ my $s = $w->slave;
+ $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
+ $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
+}
+
+sub Mapped
+{
+ my $w = shift;
+ $w->idletasks;
+ my $m = $w->manager;
+ if ($m =~ /^(?:pack|grid)$/)
+ {
+ my %info = $w->$m('info');
+ my $master = $info{'-in'};
+ $master->$m('propagate',0);
+ $w->{'master'} = $master;
+ }
+ $w->slave_expand_off;
+}
+
+sub Populate
+{
+ my ($w,$args) = @_;
+ $w->SUPER::Populate($args);
+ $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
+ $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
+
+ # Need to explicitly set frame width to 0 for Win32
+ my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
+
+ my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
+ -side => ['METHOD','side','Side','top'],
+ -delay => ['PASSIVE','delay','Delay', 1],
+ -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
+ -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
+ -restore => ['PASSIVE','restore', 'Restore', 1],
+ );
+ $w->_OnDestroy(qw(sep but lin master));
+}
+
+sub side
+{
+ my ($w,$val) = @_;
+ if (@_ > 1)
+ {
+ $w->{'side'} = $val;
+ my $cursor;
+ if ($w->vert)
+ {
+ $cursor = 'sb_h_double_arrow';
+ $w->{'sep'}->configure(-width => 2, -height => 10000);
+ }
+ else
+ {
+ $cursor = 'sb_v_double_arrow';
+ $w->{'sep'}->configure(-height => 2, -width => 10000);
+ }
+ my $x;
+ foreach $x ($w->{'sep'},$w->{'but'})
+ {
+ $x->configure(-cursor => $cursor);
+ }
+ }
+ return $w->{'side'};
+}
+
+sub slave
+{
+ my $w = shift;
+ my $s = $w->cget('-widget');
+ return $s;
+}
+
+sub vert
+{
+ my $w = shift;
+ my $side = $w->cget('-side');
+ return 1 if $side eq 'left';
+ return -1 if $side eq 'right';
+ return 0;
+}
+
+# If the Adjuster gets unmapped, it attempts to restore itself. If its
+# slave is mapped, then it reduces the size of the slave so that there is
+# then room in the master for the Adjuster widget.
+sub Restore
+{
+ my $w = shift;
+ return if ! $w->toplevel->IsMapped ||
+ ! $w->slave->IsMapped ||
+ ! $w->cget('-restore');
+ $w->vert ? $w->delta_width(0) : $w->delta_height(0);
+}
+
+sub delta_width_bar
+{
+ my ($w,$dx) = @_;
+ my $l = $w->{'lin'};
+ my $r = $w->{'sep'};
+ my $t = $w->toplevel;
+ my $m = $w->{'master'};
+ my $s = $w->slave;
+ my ($min_rootx, $max_rootx, $t_border);
+ if (! $w->{'lin_info'})
+ {
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
+ if ($w->cget('-side') eq 'right')
+ {
+ $min_rootx = $m->rootx + $m_border;
+ $max_rootx = $s->rootx + $s->width - 1;
+ }
+ else
+ {
+ $min_rootx = $s->rootx;
+ $max_rootx = $m->rootx + $m->width - $m_border - 1;
+ }
+ $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
+ }
+ else
+ {
+ ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
+ }
+ $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
+
+ my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
+ $new_rootx = $min_rootx if $new_rootx < $min_rootx;
+ $new_rootx = $max_rootx if $new_rootx > $max_rootx;
+ my $placex = $new_rootx - $t->rootx - $t_border;
+ my $placey = $w->rooty - $t->rooty - $t_border;
+ $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
+ my $this = $w->containing($new_rootx, $w->rooty + 1);
+ $l->raise($this) if $this && $this ne $t;
+}
+
+sub delta_width
+{
+ my ($w,$dx) = @_;
+ my $l = $w->{'lin'};
+ $l->placeForget;
+ my $s = $w->slave;
+ if ($s)
+ {
+ my $m = $w->{'master'};
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ my $w_width = $w->{'reqwidth'};
+ my $m_width = $m->width;
+ my $s_width = $s->width;
+ my $max_width = $m_width - $w_width;
+ my $max_s_width;
+ if ($w->cget('-side') eq 'right')
+ {
+ $dx = -$dx;
+ $max_s_width = $max_width -
+ ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
+ }
+ else
+ {
+ $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
+ }
+ my $new_width = $s_width+$dx;
+ $new_width = $max_s_width if $new_width > $max_s_width;
+ $new_width = 0 if $new_width < 0;
+ $s->GeometryRequest($new_width, $s->height);
+ }
+}
+
+sub delta_height_bar
+{
+ my ($w,$dy) = @_;
+ my $l = $w->{'lin'};
+ my $r = $w->{'sep'};
+ my $t = $w->toplevel;
+ my $m = $w->{'master'};
+ my $s = $w->slave;
+ my ($min_rooty, $max_rooty, $t_border);
+ if (! $w->{'lin_info'})
+ {
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
+ if ($w->cget('-side') eq 'bottom')
+ {
+ $min_rooty = $m->rooty + $m_border;
+ $max_rooty = $s->rooty + $s->height - 1;
+ }
+ else
+ {
+ $min_rooty = $s->rooty;
+ $max_rooty = $m->rooty + $m->height - $m_border - 1;
+ }
+ $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
+ }
+ else
+ {
+ ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
+ }
+ $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
+
+ my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
+ $new_rooty = $min_rooty if $new_rooty < $min_rooty;
+ $new_rooty = $max_rooty if $new_rooty > $max_rooty;
+ my $placey = $new_rooty - $t->rooty - $t_border;
+ my $placex = $w->rootx - $t->rootx - $t_border;
+ $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
+ my $this = $w->containing($w->rootx + 1, $new_rooty);
+ $l->raise($this) if $this && $this ne $t;
+}
+
+sub delta_height
+{
+ my ($w,$dy) = @_;
+ my $l = $w->{'lin'};
+ $l->placeForget;
+ my $s = $w->slave;
+ if ($s)
+ {
+ my $m = $w->{'master'};
+ my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
+ my $w_height = $w->{'reqheight'};
+ my $m_height = $m->height;
+ my $s_height = $s->height;
+ my $max_height = $m_height - $w_height;
+ my $max_s_height;
+ if ($w->cget('-side') eq 'bottom')
+ {
+ $dy = -$dy;
+ $max_s_height = $max_height -
+ ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
+ }
+ else
+ {
+ $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
+ }
+ my $new_height = $s_height+$dy;
+
+ $new_height = $max_s_height if $new_height > $max_s_height;
+ $new_height = 0 if $new_height < 0;
+ $s->GeometryRequest($s->width, $new_height);
+ }
+}
+
+# Turn off expansion in the slave.
+# This is done only if necessary, as calls to pack/gridConfigure cause
+# repacking.
+# Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
+# current width/height. This is because the geometry managers use
+# the requested values, not the actual, to calculate the new geometry.
+sub slave_expand_off
+{
+ my $w = shift;
+ my $s = $w->slave;
+ return if ! $s;
+
+ my $manager = $s->manager;
+ if ($manager eq 'pack')
+ {
+ my %info = $s->packInfo;
+ my $expand = $info{'-expand'};
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $s->packConfigure(-expand => 0);
+ }
+ }
+ elsif ($manager eq 'grid')
+ {
+ my %info = $s->gridInfo;
+ my $master = $info{'-in'};
+ if ($w->vert)
+ {
+ my $col = $info{'-column'};
+ my $expand = $master->gridColumnconfigure($col, '-weight');
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $master->gridColumnconfigure($col, -weight => 0);
+ }
+ }
+ else
+ {
+ my $row = $info{'-row'};
+ my $expand = $master->gridRowconfigure($row, '-weight');
+ if ($expand)
+ {
+ $s->GeometryRequest($s->width, $s->height);
+ $master->gridRowconfigure($row, -weight => 0);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+=cut #' emacs hilighting...
diff --git a/Master/tlpkg/tlperl/lib/Tk/After.pm b/Master/tlpkg/tlperl/lib/Tk/After.pm
new file mode 100644
index 00000000000..85a0e406ee5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/After.pm
@@ -0,0 +1,104 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::After;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $
+
+sub _cancelAll
+{
+ my $w = shift;
+ my $h = delete $w->{_After_};
+ foreach my $obj (values %$h)
+ {
+ # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
+ $obj->cancel;
+ bless $obj,"Tk::After::Cancelled";
+ }
+}
+
+sub Tk::After::Cancelled::once { }
+sub Tk::After::Cancelled::repeat { }
+
+sub submit
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ my $t = $obj->[2];
+ my $method = $obj->[3];
+ delete($w->{_After_}{$id}) if (defined $id);
+ $id = $w->Tk::after($t,[$method => $obj]);
+ unless (exists $w->{_After_})
+ {
+ $w->{_After_} = {};
+ $w->OnDestroy([\&_cancelAll, $w]);
+ }
+ $w->{_After_}{$id} = $obj;
+ $obj->[1] = $id;
+ return $obj;
+}
+
+sub DESTROY
+{
+ my $obj = shift;
+ $obj->cancel;
+ undef $obj->[0];
+ undef $obj->[4];
+}
+
+sub new
+{
+ my ($class,$w,$t,$method,@cb) = @_;
+ my $cb = (@cb == 1) ? shift(@cb) : [@cb];
+ my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
+ return $obj->submit;
+}
+
+sub cancel
+{
+ my $obj = shift;
+ my $id = $obj->[1];
+ my $w = $obj->[0];
+ if ($id)
+ {
+ $w->Tk::after('cancel'=> $id) if Tk::Exists($w);
+ delete $w->{_After_}{$id} if exists $w->{_After_};
+ $obj->[1] = undef;
+ }
+ return $obj;
+}
+
+sub repeat
+{
+ my $obj = shift;
+ $obj->submit;
+ local $Tk::widget = $obj->[0];
+ $obj->[4]->Call;
+}
+
+sub once
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ delete $w->{_After_}{$id};
+ local $Tk::widget = $w;
+ $obj->[4]->Call;
+}
+
+sub time {
+ my $obj = shift;
+ my $delay = shift;
+ if (defined $delay) {
+ $obj->cancel if $delay == 0;
+ $obj->[2] = $delay;
+ }
+ $obj->[2];
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Animation.pm b/Master/tlpkg/tlperl/lib/Tk/Animation.pm
new file mode 100644
index 00000000000..428f3f1f48f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Animation.pm
@@ -0,0 +1,178 @@
+package Tk::Animation;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $
+
+use Tk::Photo;
+use base qw(Tk::Photo);
+
+Construct Tk::Widget 'Animation';
+
+sub MainWindow
+{
+ return shift->{'_MainWIndow_'};
+}
+
+sub add_frame
+{
+ my $obj = shift;
+ $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'};
+ push(@{$obj->{'_frames_'}},@_);
+}
+
+sub new
+{
+ my ($class,$widget,%args) = @_;
+ my $obj = $class->SUPER::new($widget,%args);
+ $obj->{'_MainWIndow_'} = $widget->MainWindow;
+ if ($args{'-format'} eq 'gif')
+ {
+ my @images;
+ local $@;
+ while (1)
+ {
+ my $index = @images;
+ $args{'-format'} = "gif -index $index";
+ my $img;
+ eval {local $SIG{'__DIE__'}; $img = $class->SUPER::new($widget,%args) };
+ last if $@;
+ push(@images,$img);
+ }
+ if (@images > 1)
+ {
+ $obj->add_frame(@images);
+ $obj->{'_frame_index_'} = 0;
+ }
+ }
+ $obj->set_image( 0 );
+ $obj->{_delta_} = 1;
+ $obj->{_blank_} = 0;
+ return $obj;
+}
+
+sub fast_forward {
+
+ my( $self, $delta) = @_;
+
+ $self->{_delta_} = $delta;
+ if( not exists $self->{_playing_} ) {
+ my $playing = exists $self->{'_NextId_'};
+ $self->{_playing_} = $playing;
+ $self->resume_animation if not $playing;
+ } else {
+ my $playing = delete $self->{_playing_};
+ $self->pause_animation if not $playing;
+ }
+
+} # end fast_forward
+
+*fast_reverse = \&fast_forward;
+
+sub frame_count {
+ my $frames = shift->{'_frames_'};
+ return -1 unless $frames;
+ return @$frames;
+}
+
+sub blank {
+ my( $self, $blank ) = @_;
+ $blank = 1 if not defined $blank;
+ $self->{_blank_} = $blank;
+ $blank;
+}
+
+sub set_image
+{
+ my ($obj,$index) = @_;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ $index = 0 unless $index < @$frames;
+ $obj->blank if $obj->{_blank_}; # helps some make others worse
+ $obj->copy($frames->[$index]);
+ $obj->{'_frame_index_'} = $index;
+}
+
+sub next_image
+{
+ my ($obj, $delta) = @_;
+ $delta = $obj->{_delta_} unless $delta;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ $obj->set_image((($obj->{'_frame_index_'} || 0) + $delta) % @$frames);
+}
+
+sub prev_image { shift->next_image( -1 ) }
+
+sub pause_animation {
+ my $self = shift;
+ my $id = delete $self->{'_NextId_'};
+ Tk::catch { $id->cancel } if $id;
+}
+
+sub resume_animation {
+ my( $self, $period ) = @_;
+ if( not defined $self->{'_period_'} ) {
+ $self->{'_period_'} = defined( $period ) ? $period : 100;
+ }
+ $period = $self->{'_period_'};
+ my $w = $self->MainWindow;
+ $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image' ] );
+}
+
+sub start_animation
+{
+ my ($obj,$period) = @_;
+ $period ||= 100;
+ my $frames = $obj->{'_frames_'};
+ return unless $frames && @$frames;
+ my $w = $obj->MainWindow;
+ $obj->stop_animation;
+ $obj->{'_period_'} = $period;
+ $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']);
+}
+
+sub stop_animation
+{
+ my ($obj) = @_;
+ my $id = delete $obj->{'_NextId_'};
+ Tk::catch { $id->cancel } if $id;
+ $obj->set_image(0);
+}
+
+1;
+__END__
+
+=cut
+
+#
+# This almost works for changing the animation on the fly
+# but does not resize things correctly
+#
+
+sub gif_sequence
+{
+ my ($obj,%args) = @_;
+ my $widget = $obj->MainWindow;
+ my @images;
+ local $@;
+ while (1)
+ {
+ my $index = @images;
+ $args{'-format'} = "gif -index $index";
+ my $img;
+ eval
+ {local $SIG{'__DIE__'};
+ my $img = $widget->Photo(%args);
+ push(@images,$img);
+ };
+ last if $@;
+ }
+ if (@images)
+ {
+ delete $obj->{'_frames_'};
+ $obj->add_frame(@images);
+ $obj->configure(-width => 0, -height => 0);
+ $obj->set_frame(0);
+ }
+}
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Balloon.pm b/Master/tlpkg/tlperl/lib/Tk/Balloon.pm
new file mode 100644
index 00000000000..2ee0f6c3bce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Balloon.pm
@@ -0,0 +1,621 @@
+#
+# The help widget that provides both "balloon" and "status bar"
+# types of help messages.
+#
+# This is a patched version of Balloon 3.037 - it adds support
+# for different orientations of the balloon widget, depending
+# on wether there's enough space for it. The little arrow now
+# should always point directly to the client.
+# Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com)
+#
+# Nov 1, 2003 - Jack Dunnigan
+# Added support for more than one screen in single logical
+# screen mode (i.e. xinerama, dual monitors)
+
+package Tk::Balloon;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev Exists);
+use Carp;
+require Tk::Toplevel;
+
+Tk::Widget->Construct('Balloon');
+use base qw(Tk::Toplevel);
+
+# use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core
+
+use strict;
+
+my @balloons;
+my $button_up = 0;
+my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7',
+ TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==',
+ BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=',
+ BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=',
+ NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw=='
+ );
+
+
+sub ClassInit {
+ my ($class, $mw) = @_;
+ $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
+ $mw->bind('all', '<Leave>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
+ $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown');
+ $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp');
+ return $class;
+}
+
+sub Populate {
+ my ($w, $args) = @_;
+
+ $w->SUPER::Populate($args);
+
+ $w->overrideredirect(1);
+ $w->withdraw;
+ # Only the container frame's background should be black... makes it
+ # look better.
+ $w->configure(-background => 'black');
+
+ # the balloon arrows
+ $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif');
+ $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif');
+ $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif');
+ $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif');
+ $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif');
+ $w->OnDestroy([$w, '_destroyed']);
+
+ $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no});
+
+ # the balloon message
+ # We give the Label a big borderwidth
+ # ..enough to slide a 6x6 gif image along the border including some space
+
+ my $ml = $w->Label(-bd => 0,
+ -padx => 10,
+ -pady => 3,
+ -justify => 'left',
+ -relief=>'flat');
+ $w->Advertise('message' => $ml);
+
+ $ml->pack(
+ -side => 'top',
+ -anchor => 'nw',
+ -expand => 1,
+ -fill => 'both',
+ -padx => 0,
+ -pady => 0);
+
+ # append to global list of balloons
+ push(@balloons, $w);
+ $w->{'popped'} = 0;
+ $w->{'buttonDown'} = 0;
+ $w->{'menu_index'} = 'none';
+ $w->{'menu_index_over'} = 'none';
+ $w->{'canvas_tag'} = '';
+ $w->{'canvas_tag_over'} = '';
+ $w->{'current_screen'} = 0;
+
+ $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0],
+ -initwait => ['PASSIVE', 'initWait', 'InitWait', 350],
+ -state => ['PASSIVE', 'state', 'State', 'both'],
+ -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef],
+ -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''],
+ -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''],
+ -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'],
+ -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef],
+ -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef],
+ -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef],
+ -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'],
+ -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef],
+ -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
+ -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1],
+ -numscreens=>['PASSIVE', 'numScreens','NumScreens',1],
+ );
+}
+
+# attach a client to the balloon
+sub attach {
+ my ($w, $client, %args) = @_;
+ foreach my $key (grep(/command$/,keys %args))
+ {
+ $args{$key} = Tk::Callback->new($args{$key});
+ }
+ my $msg = delete $args{-msg};
+ $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
+ $args{-statusmsg} = $msg unless exists $args{-statusmsg};
+ $w->{'clients'}{$client} = \%args;
+ $client->OnDestroy([$w, 'detach', $client]);
+}
+
+# detach a client from the balloon.
+sub detach {
+ my ($w, $client) = @_;
+ if (Exists($w))
+ {
+ $w->Deactivate if ($client->IS($w->{'client'}));
+ }
+ delete $w->{'clients'}{$client};
+}
+
+sub GetOption
+{
+ my ($w,$opt,$client) = @_;
+ $client = $w->{'client'} unless defined $client;
+ if (defined $client)
+ {
+ my $info = $w->{'clients'}{$client};
+ return $info->{$opt} if exists $info->{$opt};
+ }
+ return $w->cget($opt);
+}
+
+sub Motion {
+ my ($ewin, $x, $y, $s) = @_;
+
+ return if not defined $ewin;
+
+ # Find which window we are over
+ my $over = $ewin->Containing($x, $y);
+
+ return if &grabBad($ewin, $over);
+
+ foreach my $w (@balloons) {
+ # if cursor has moved over the balloon -- ignore
+ next if defined $over and $over->toplevel eq $w;
+
+ # find the client window that matches
+ my $client = $over;
+ while (defined $client) {
+ last if (exists $w->{'clients'}{$client});
+ $client = $client->Parent;
+ }
+ if (defined $client) {
+ # popping up disabled -- ignore
+ my $state = $w->GetOption(-state => $client);
+ next if $state eq 'none';
+ # Check if a button was recently released:
+ my $deactivate = 0;
+ if ($button_up) {
+ $deactivate = 1;
+ $button_up = 0;
+ }
+ # Deactivate it if the motioncommand says to:
+ my $command = $w->GetOption(-motioncommand => $client);
+ $deactivate = $command->Call($client, $x, $y) if defined $command;
+ if ($deactivate)
+ {
+ $w->Deactivate;
+ }
+ else
+ {
+ # warn "deact: $client $w->{'client'}";
+ $w->Deactivate unless $client->IS($w->{'client'});
+ my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
+ if (defined($msg))
+ {
+ my $delay = delete $w->{'delay'};
+ $delay->cancel if defined $delay;
+ my $initwait = $w->GetOption(-initwait => $client);
+ $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
+ $w->{'client'} = $client;
+ }
+ }
+ } else {
+ # cursor is at a position covered by a non client
+ # pop down the balloon if it is up or scheduled.
+ $w->Deactivate;
+ }
+ }
+}
+
+sub ButtonDown {
+ my ($ewin) = @_;
+
+ foreach my $w (@balloons) {
+ $w->Deactivate;
+ }
+}
+
+sub ButtonUp {
+ $button_up = 1;
+}
+
+# switch the balloon to a new client
+sub SwitchToClient {
+ my ($w, $client) = @_;
+ return unless Exists($w);
+ return unless Exists($client);
+ return unless $client->IS($w->{'client'});
+ return if &grabBad($w, $client);
+ my $command = $w->GetOption(-postcommand => $client);
+ if (defined $command) {
+ # Execute the user's command and return if it returns false:
+ my $pos = $command->Call($client);
+ return if not $pos;
+ if ($pos =~ /^(\d+),(\d+)$/) {
+ # Save the returned position so the Popup method can use it:
+ $w->{'clients'}{$client}{'postposition'} = [$1, $2];
+ }
+ }
+ my $state = $w->GetOption(-state => $client);
+ $w->Popup if ($state =~ /both|balloon/);
+ $w->SetStatus if ($state =~ /both|status/);
+ $w->{'popped'} = 1;
+ $w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]);
+}
+
+sub grabBad {
+
+ my ($w, $client) = @_;
+
+ return 0 unless Exists($client);
+ my $g = $w->grabCurrent;
+ return 0 unless defined $g;
+ return 0 if $g->isa('Tk::Menu');
+ return 0 if $g eq $client;
+
+ # The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk
+ # pathname (yes, it's cheating, but it's legal).
+
+ return 0 if $g == $w->MainWindow;
+ my $wp = $w->PathName;
+ my $gp = $g->PathName;
+ return 0 if $wp =~ /^$gp/;
+ return 1; # bad grab
+
+} # end grabBad
+
+
+sub Subclient
+{
+ my ($w,$data) = @_;
+ if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
+ {
+ $w->Deactivate;
+ }
+ $w->{'subclient'} = $data;
+}
+
+sub Verify {
+ my $w = shift;
+ my $client = shift;
+ my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
+ my $over = $w->Containing($X,$Y);
+ return if not defined $over or ($over->toplevel eq $w);
+ my $deactivate = # DELETE? or move it to the isa-Menu section?:
+ # ($over ne $client) or
+ not $client->IS($w->{'client'})
+# or (!$client->isa('Tk::Menu') && $w->grabCurrent);
+# or $w->grabbad($client);
+ or &grabBad($w, $client);
+ if ($deactivate)
+ {
+ $w->Deactivate;
+ }
+ else
+ {
+ $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
+ }
+}
+
+sub Deactivate {
+ my ($w) = @_;
+ my $delay = delete $w->{'delay'};
+ $delay->cancel if defined $delay;
+ if ($w->{'popped'}) {
+ my $client = $w->{'client'};
+ my $command = $w->GetOption(-cancelcommand => $client);
+ if (defined $command) {
+ # Execute the user's command and return if it returns false:
+ return if not $command->Call($client);
+ }
+ $w->withdraw;
+ $w->ClearStatus;
+ $w->{'popped'} = 0;
+ $w->{'menu_index'} = 'none';
+ $w->{'canvas_tag'} = '';
+ }
+ $w->{'client'} = undef;
+ $w->{'subclient'} = undef;
+ $w->{'location'} = undef;
+}
+
+sub Popup {
+ my ($w) = @_;
+ if ($w->cget(-installcolormap)) {
+ $w->colormapwindows($w->winfo('toplevel'))
+ }
+ my $client = $w->{'client'};
+ return if not defined $client or not exists $w->{'clients'}{$client};
+ my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
+ # Dereference it if it looks like a scalar reference:
+ $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
+
+ $w->Subwidget('message')->configure(-text => $msg);
+ $w->idletasks;
+
+ return unless Exists($w);
+ return unless Exists($client);
+ return if $msg eq ''; # Don't popup empty balloons.
+
+ my ($x, $y);
+ my $pos = $w->GetOption(-balloonposition => $client);
+ my $postpos = delete $w->{'clients'}{$client}{'postposition'};
+ if (defined $postpos) {
+ # The postcommand must have returned a position for the balloon - I will use that:
+ ($x,$y) = @{$postpos};
+ } elsif ($pos eq 'mouse') {
+ ($x,$y)=$client->pointerxy; # We adjust the position later
+ } elsif ($pos eq 'widget') {
+ $x = int($client->rootx + $client->width/2);
+ $y = int($client->rooty + int ($client->height/1.3));
+ } else {
+ croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
+ }
+
+ $w->idletasks;
+
+ # Explanation of following code. [JD]
+ # PREMISE: We want to ensure that the balloon is always "on screen".
+ # To do this we use calculate the size of the
+ # toplevel before it is mapped. Then we adjust it's position with respect to the
+ # mouse cursor or widget. Balloons are usually shown below and to the right of the target.
+ # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
+ # the balloon will extend across two monitors in single logical screen mode (SLS).
+ # This is an undesirable characteristic indeed. Trying to read a disjointed balloon
+ # across monitors is not fun.
+ #
+ # The intent of the following code is to fix this problem. We do this by avoiding
+ # placement of any part of the balloon over,say, the "half screenwidth" mark (for two
+ # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
+ # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
+ # boundaries to be avoided.
+ #
+ # The only drawback of this code, is I know of no way to actually determine this on a
+ # user by user basis. This means that the developer or administrator will have to know
+ # the hardware (monitor) setup for which the application is designed.
+ #
+ # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
+ # of creating four separate labels, we configure only ONE label with the proper image.
+ # Then using the place geometry manager, this image/label can be "slid" along the
+ # appropriate side of the toplevel so that it always points directly at the target widget.
+ #
+ # Here we go..
+
+ my ($width, $height) = ($w->reqwidth, $w->reqheight);
+ my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
+ my $numscreen = $w->cget(-numscreens);
+ my $deltax = $sw/$numscreen;
+ my $leftedge;
+ my $rightedge;
+ my $count = 0;
+ for (my $i=0; $i<$sw; $i+=$deltax){
+ $leftedge = $i;
+ $rightedge = $i + $deltax;
+ if ($x >= $leftedge && $x < $rightedge ){
+ last;
+ }
+ $count++;
+ }
+
+ # Force another look at balloon location because mouse has switched
+ # virtual screens.
+ $w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
+ $w->{'current_screen'} = $count;
+
+ my $xx=undef;
+ my $yy=undef; # to hold final toplevel placement
+ my $slideOffsetX = 0;
+ my $slideOffsetY = 0;
+ my $cornerOffset = 5; #default - keep corner away from pointer
+ my $testtop = $y - $height - $cornerOffset;
+ my $testbottom = $y + $height + (2*$cornerOffset);
+ my $testright = $x + $width + (2*$cornerOffset);
+ my $testleft = $x - $width - $cornerOffset;
+ my $vert='bottom'; #default
+ my $horiz='right'; #default
+
+
+ if ( defined $w->{'location'} ){
+ # Once balloon is activated, **don't** change the location of the balloon.
+ # It is annoying to have it jump from one location to another.
+ ( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' );
+ ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
+
+ if ($vert eq 'top' && $testtop < 0) {
+ $yy = 0;
+ $slideOffsetY = $testtop;
+ }
+ elsif ($vert eq 'bottom' && $testbottom > $sh) {
+ $slideOffsetY = $testbottom - $sh;
+ }
+
+ if ($horiz eq 'left' && $testleft < $leftedge) {
+ $xx = $leftedge;
+ }
+ elsif ($horiz eq 'right' && $testright > $rightedge) {
+ $slideOffsetX = $testright - $rightedge;
+ }
+ }
+ else {
+ #Test balloon positions in the vertical
+ if ($testbottom > $sh) {
+ #Then offscreen to bottom, check top
+ if ($testtop >= 0) {
+ $vert = 'top';
+ }
+ elsif ($y > $sh/2) {
+ #still offscreen to top but there is more room above then below
+ $vert = 'top';
+ $yy=0;
+ $slideOffsetY = $testtop;
+ }
+ if ($vert eq 'bottom'){
+ #Calculate Yoffset to fit entire balloon onto screen
+ $slideOffsetY = $testbottom - $sh;
+ }
+ }
+ #Test balloon positions in the horizontal
+
+ if ($testright > $rightedge) {
+ #The offscreen, check left
+ if ($testleft >= $leftedge) {
+ $horiz = 'left';
+ }
+ elsif ($x > ($leftedge+$deltax) ) {
+ #still offscreen to left but there is more room to left than right
+ $horiz = 'left';
+ $xx=0;
+ $slideOffsetX = $testleft;
+ }
+ if ($horiz eq 'right'){
+ #Calculate Xoffset to fit entire balloon onto screen
+ $slideOffsetX = $testright - $rightedge;
+ }
+ }
+ }
+
+ $w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
+
+ if ($w->{'location'} eq 'bottomright') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_tl});
+ }
+
+ $w->{'pointer'}->place(
+ -in=>$w,
+# -relx=>0, -x=>$slideOffsetX + 2,
+# -rely=>0, -y=>$slideOffsetY + 2,
+ -relx=>0, -x=>2,
+ -rely=>0, -y=>2,
+ -bordermode=>'outside',
+ -anchor=>'nw');
+
+ $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
+ $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
+
+ }
+ elsif ($w->{'location'} eq 'bottomleft') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_tr});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>1, -x=>$slideOffsetX - 2,
+# -rely=>0, -y=>$slideOffsetY + 2,
+ -relx=>1, -x=>-2,
+ -rely=>0, -y=>2,
+ -bordermode=>'outside',
+ -anchor=>'ne');
+
+ $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
+ $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
+
+ }
+ elsif ($w->{'location'} eq 'topright') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_bl});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>0, -x=>$slideOffsetX + 2,
+# -rely=>1, -y=>$slideOffsetY - 2,
+ -relx=>0, -x=>2,
+ -rely=>1, -y=>-2,
+ -bordermode=>'outside',
+ -anchor=>'sw');
+
+ $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
+ $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
+ }
+ elsif ($w->{'location'} eq 'topleft') {
+ if ( $slideOffsetX or $slideOffsetY ) {
+ $w->{'pointer'}->configure(-image => $w->{img_no});
+ }
+ else {
+ $w->{'pointer'}->configure(-image => $w->{img_br});
+ }
+
+ $w->{'pointer'}->place(-in=>$w,
+# -relx=>1, -x=>$slideOffsetX - 2,
+# -rely=>1, -y=>$slideOffsetY - 2,
+ -relx=>1, -x=>-2,
+ -rely=>1, -y=>-2,
+ -bordermode=>'outside',
+ -anchor=>'se');
+
+ $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
+ $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
+ }
+
+ $w->{'pointer'}->raise;
+ $xx = int($xx);
+ $yy = int($yy);
+ $w->geometry("+$xx+$yy");
+ $w->deiconify();
+ $w->raise;
+}
+
+sub SetStatus {
+ my ($w) = @_;
+ my $client = $w->{'client'};
+ my $s = $w->GetOption(-statusbar => $client);
+ if (defined $s and $s->winfo('exists')) {
+ my $vref = $s->cget(-textvariable);
+ return if not defined $client or not exists $w->{'clients'}{$client};
+ my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
+ # Dereference it if it looks like a scalar reference:
+ $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
+ if (not defined $vref) {
+ eval { $s->configure(-text => $msg); };
+ } else {
+ $$vref = $msg;
+ }
+ }
+}
+
+sub ClearStatus {
+ my ($w) = @_;
+ my $client = $w->{'client'};
+ my $s = $w->GetOption(-statusbar => $client);
+ if (defined $s and $s->winfo('exists')) {
+ my $vref = $s->cget(-textvariable);
+ if (defined $vref) {
+ $$vref = '';
+ } else {
+ eval { $s->configure(-text => ''); }
+ }
+ }
+}
+
+sub _destroyed {
+ my ($w) = @_;
+ # This is called when widget is destroyed (no matter how!)
+ # via the ->OnDestroy hook set in Populate.
+ # remove ourselves from the list of baloons.
+ @balloons = grep($w != $_, @balloons);
+
+ # FIXME: If @balloons is now empty perhaps remove the 'all' bindings
+ # to reduce overhead until another balloon is created?
+
+ # Delete the images
+ for (qw(no tl tr bl br)) {
+ my $img = delete $w->{"img_$_"};
+ $img->delete if defined $img;
+ }
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm b/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm
new file mode 100644
index 00000000000..d081a393804
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Bitmap.pm
@@ -0,0 +1,10 @@
+package Tk::Bitmap;
+require Tk;
+require Tk::Image;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Bitmap.pm#4 $
+use base qw(Tk::Image);
+Construct Tk::Image 'Bitmap';
+sub Tk_image { 'bitmap' }
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm b/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm
new file mode 100644
index 00000000000..5c4b6b782c2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/BrowseEntry.pm
@@ -0,0 +1,510 @@
+#
+# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
+#
+# Some additions by Slaven Rezic <slaven@rezic.de> to make the widget
+# look like the Windows' Combobox. There are also additional options.
+#
+
+package Tk::BrowseEntry;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev);
+use Carp;
+use strict;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'BrowseEntry';
+
+require Tk::LabEntry;
+
+sub LabEntryWidget { "LabEntry" }
+sub ButtonWidget { "Button" }
+sub ListboxWidget { "Listbox" }
+
+sub Populate {
+ my ($w, $args) = @_;
+
+ $w->Tk::Frame::Populate($args);
+
+ # entry widget and arrow button
+ my $lpack = delete $args->{-labelPack};
+ if (not defined $lpack) {
+ $lpack = [-side => 'left', -anchor => 'e'];
+ }
+ $w->{_BE_Style} = delete $args->{-style} || $Tk::platform;
+ my $LabEntry = $w->LabEntryWidget;
+ my $Listbox = $w->ListboxWidget;
+ my $Button = $w->ButtonWidget;
+ # XXX should this be retained?
+# if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time
+# $LabEntry = "NoSelLabEntry";
+# require Tk::NoSelLabEntry;
+# }
+ my $e;
+ my $var = "";
+ my @LabEntry_args = (-textvariable => \$var);
+ if (exists $args->{-label}) {
+ $e = $w->$LabEntry(-labelPack => $lpack,
+ -label => delete $args->{-label},
+ @LabEntry_args,
+ );
+ } else {
+ $e = $w->$LabEntry(@LabEntry_args);
+ }
+ my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm'));
+ $w->Advertise('entry' => $e);
+ $w->Advertise('arrow' => $b);
+
+ # Pack the button to align vertically with the entry widget
+ my @anch;
+ my $edge = {@$lpack}->{-side};
+ push(@anch,-anchor => 's') if ($edge && $edge eq 'top');
+ push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom');
+ $b->pack(-side => 'right', -padx => 1, @anch);
+
+ $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1);
+
+ # popup shell for listbox with values.
+ my $c = $w->Toplevel(-bd => 2,
+ -relief => ($w->{_BE_Style} eq 'MSWin32'
+ ? "solid" : "raised"));
+ $c->overrideredirect(1);
+ $c->withdraw;
+ my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ );
+ if ($w->{_BE_Style} eq 'MSWin32' and $Tk::platform eq 'MSWin32') {
+ $sl->configure(-bg => 'SystemWindow', -relief => "flat");
+ }
+ $w->Advertise('choices' => $c);
+ $w->Advertise('slistbox' => $sl);
+ $sl->pack(-expand => 1, -fill => 'both');
+
+ $sl->Subwidget("scrolled")->bind("<Motion>",sub {
+ return unless ($w->{_BE_Style} eq 'MSWin32');
+ my $e = $_[0]->XEvent;
+ my $y = $e->y;
+ my $inx = $sl->nearest($y);
+ if (defined $inx) {
+ $sl->selectionClear(0, "end");
+ $sl->selectionSet($inx);
+ }
+ });
+
+ # other initializations
+ $w->SetBindings;
+ $w->{'_BE_popped'} = 0;
+ $w->Delegates(get => $sl, DEFAULT => $e);
+ $w->ConfigSpecs(
+ -font => [qw/DESCENDANTS font Font/],
+ -listwidth => [qw/PASSIVE listWidth ListWidth/, undef],
+ -listheight => [{-height => $sl}, qw/listHeight ListHeight/, undef],
+ -listcmd => [qw/CALLBACK listCmd ListCmd/, undef],
+ -autolistwidth => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
+ -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
+ -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef],
+ -browse2cmd => [qw/CALLBACK browse2Cmd Browse2Cmd/, undef],
+ -choices => [qw/METHOD choices Choices/, undef],
+ -state => [qw/METHOD state State normal/],
+ -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
+ -variable => [ {'-textvariable' => $e} ],
+ -colorstate => [qw/PASSIVE colorState ColorState/, undef],
+ -command => '-browsecmd',
+ -options => '-choices',
+ -label => [qw/PASSIVE label Label/, undef],
+ -labelPack => [qw/PASSIVE labelPack LabelPack/, undef],
+ #-background => [$e, qw/background Background/, undef],
+ #-foreground => [$e, qw/foreground Foreground/, undef],
+ -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
+ 'ButtonTakefocus', 1],
+ DEFAULT => [$e] );
+}
+
+sub SetBindings {
+ my ($w) = @_;
+
+ my $e = $w->Subwidget('entry');
+ my $b = $w->Subwidget('arrow');
+
+ # set bind tags
+ $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
+ # as we don't bind $e here leave its tags alone ...
+ # $e->bindtags([$e, ref($e), $e->toplevel, 'all']);
+
+ # bindings for the button and entry
+ $b->bind('<1>',[$w,'BtnDown']);
+ $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
+ $b->bind('<space>',[$w,'space']);
+
+ # bindings for listbox
+ my $sl = $w->Subwidget('slistbox');
+ my $l = $sl->Subwidget('listbox');
+ $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
+ $l->bind('<Escape>' => [$w,'LbClose']);
+ $l->bind('<Return>' => [$w,'Return',$l]);
+
+ # allow click outside the popped up listbox to pop it down.
+ $w->bind('<1>','BtnDown');
+}
+
+sub space
+{
+ my $w = shift;
+ $w->BtnDown;
+ $w->{'_BE_savefocus'} = $w->focusCurrent;
+ $w->Subwidget('slistbox')->focus;
+}
+
+
+sub ListboxRelease
+{
+ my ($w,$x,$y) = @_;
+ $w->ButtonHack;
+ $w->LbChoose($x, $y);
+}
+
+sub Return
+{
+ my ($w,$l) = @_;
+ my($x, $y) = $l->bbox($l->curselection);
+ $w->LbChoose($x, $y)
+}
+
+
+sub BtnDown {
+ my ($w) = @_;
+ return if $w->cget( '-state' ) eq 'disabled';
+
+ if ($w->{'_BE_popped'}) {
+ $w->Popdown;
+ $w->{'_BE_buttonHack'} = 0;
+ } else {
+ $w->PopupChoices;
+ $w->{'_BE_buttonHack'} = 1;
+ }
+}
+
+sub PopupChoices {
+ my ($w) = @_;
+
+ if (!$w->{'_BE_popped'}) {
+ $w->Callback(-listcmd => $w);
+ my $e = $w->Subwidget('entry');
+ my $c = $w->Subwidget('choices');
+ my $s = $w->Subwidget('slistbox');
+ my $a = $w->Subwidget('arrow');
+ my $y1 = ($w->{_BE_Style} eq 'MSWin32'
+ ? $a->rooty + $a->height
+ : $e->rooty + $e->height + 3
+ );
+ my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
+ # using the real listbox reqheight rather than the
+ # container frame one, which does not change after resizing the
+ # listbox
+ my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
+ my $x1 = ($w->{_BE_Style} eq 'MSWin32'
+ ? $e->Subwidget("entry")->rootx
+ : $e->rootx
+ );
+ my ($width, $x2);
+ if (defined $w->cget(-listwidth)) {
+ $width = $w->cget(-listwidth);
+ $x2 = $x1 + $width;
+ } else {
+ $x2 = $a->rootx + $a->width;
+ $width = $x2 - $x1;
+ }
+ my $rw = $c->reqwidth;
+ if ($rw < $width) {
+ $rw = $width
+ } else {
+ if ($rw > $width * 3) {
+ $rw = $width * 3;
+ }
+ if ($rw > $w->vrootwidth) {
+ $rw = $w->vrootwidth;
+ }
+ }
+ $width = $rw;
+
+ # if listbox is too far right, pull it back to the left
+ #
+ if ($x2 > $w->vrootwidth) {
+ $x1 = $w->vrootwidth - $width;
+ }
+
+ # if listbox is too far left, pull it back to the right
+ #
+ if ($x1 < 0) {
+ $x1 = 0;
+ }
+
+ # if listbox is below bottom of screen, pull it up.
+ # check the Win32 taskbar, if possible
+ my $rootheight;
+ if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
+ eval {
+ require Win32Util; # XXX should not use a non-CPAN widget
+ $rootheight = (Win32Util::screen_region($w))[3];
+ };
+ }
+ if (!defined $rootheight) {
+ $rootheight = $w->vrootheight;
+ }
+
+ my $y2 = $y1 + $ht;
+ if ($y2 > $rootheight) {
+ $y1 = $y1 - $ht - ($e->height - 5);
+ }
+ $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
+ $c->deiconify;
+ $c->raise;
+ $e->focus;
+ $w->{'_BE_popped'} = 1;
+
+ # highlight current selection
+ my $current_sel = $e->get;
+ if (defined $current_sel) {
+ my $i = 0;
+ foreach my $str ($s->get(0, "end")) {
+ if ($str eq $current_sel) {
+ $s->selectionClear(0, "end");
+ $s->selectionSet($i);
+ last;
+ }
+ $i++;
+ }
+ }
+
+ $c->configure(-cursor => 'arrow');
+ $w->{'_BE_grabinfo'} = $w->grabSave;
+ $w->grabGlobal;
+ }
+}
+
+# choose value from listbox if appropriate
+sub LbChoose {
+ my ($w, $x, $y) = @_;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ if ((($x < 0) || ($x > $l->Width)) ||
+ (($y < 0) || ($y > $l->Height))) {
+ # mouse was clicked outside the listbox... close the listbox
+ $w->LbClose;
+ } else {
+ # select appropriate entry and close the listbox
+ $w->LbCopySelection;
+ $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
+ $w->Callback(-browse2cmd => $w, $w->LbIndex);
+ }
+}
+
+# close the listbox after clearing selection
+sub LbClose {
+ my ($w) = @_;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ $l->selection('clear', 0, 'end');
+ $w->Popdown;
+}
+
+# copy the selection to the entry and close listbox
+sub LbCopySelection {
+ my ($w) = @_;
+ my $index = $w->LbIndex;
+ if (defined $index) {
+ $w->{'_BE_curIndex'} = $index;
+ my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
+ my $var_ref = $w->cget( '-textvariable' );
+ $$var_ref = $l->get($index);
+ if ($w->{'_BE_popped'}) {
+ $w->Popdown;
+ }
+ }
+ $w->Popdown;
+}
+
+sub LbIndex {
+ my ($w, $flag) = @_;
+ my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
+ if (defined $sel) {
+ return int($sel);
+ } else {
+ if (defined $flag && ($flag eq 'emptyOK')) {
+ return undef;
+ } else {
+ return 0;
+ }
+ }
+}
+
+# pop down the listbox
+sub Popdown {
+ my ($w) = @_;
+ if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) {
+ $w->{'_BE_savefocus'}->focus;
+ delete $w->{'_BE_savefocus'};
+ }
+ if ($w->{'_BE_popped'}) {
+ my $c = $w->Subwidget('choices');
+ $c->withdraw;
+ $w->grabRelease;
+ if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
+ $w->{'_BE_grabinfo'}->();
+ delete $w->{'_BE_grabinfo'};
+ }
+ $w->{'_BE_popped'} = 0;
+ }
+}
+
+# This hack is to prevent the ugliness of the arrow being depressed.
+#
+sub ButtonHack {
+ my ($w) = @_;
+ my $b = $w->Subwidget('arrow');
+ if ($w->{'_BE_buttonHack'}) {
+ $b->butUp;
+ }
+}
+
+sub choices
+{
+ my ($w,$choices) = @_;
+ if (@_ > 1)
+ {
+ $w->delete( qw/0 end/ );
+ my %hash;
+ my $var = $w->cget('-textvariable');
+ my $old = $$var;
+ foreach my $val (@$choices)
+ {
+ $w->insert( 'end', $val);
+ $hash{$val} = 1;
+ }
+ $old = $choices->[0]
+ if defined $old && not exists $hash{$old} && defined $choices->[0];
+ $$var = $old;
+ }
+ else
+ {
+ return( $w->get( qw/0 end/ ) );
+ }
+}
+
+sub _set_edit_state {
+ my( $w, $state ) = @_;
+
+ my $entry = $w->Subwidget( 'entry' );
+ my $button = $w->Subwidget( 'arrow' );
+
+ if ($w->cget( '-colorstate' )) {
+ my $color;
+ if( $state eq 'normal' ) { # Editable
+ $color = 'gray95';
+ } else { # Not Editable
+ $color = $w->cget( -background ) || 'lightgray';
+ }
+ $entry->Subwidget( 'entry' )->configure( -background => $color );
+ }
+
+ if( $state eq 'readonly' ) {
+ $entry->configure( -state => 'disabled' );
+ $button->configure( -state => 'normal' );
+ if ($w->{_BE_Style} eq 'MSWin32') {
+ $entry->bind('<1>',[$w,'BtnDown']);
+ $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
+ $entry->configure( -cursor => 'left_ptr' );
+ }
+ } else {
+ $entry->configure( -state => $state );
+ if (exists $w->{_BE_OriginalCursor}) {
+ $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
+ }
+ $button->configure( -state => $state );
+ if ($w->{_BE_Style} eq 'MSWin32') {
+ $entry->bind('<1>',['Button1',Tk::Ev('x')]);
+ }
+ }
+}
+
+sub state {
+ my $w = shift;
+ unless( @_ ) {
+ return( $w->{Configure}{-state} );
+ } else {
+ my $state = shift;
+ $w->{Configure}{-state} = $state;
+ $w->_set_edit_state( $state );
+ }
+}
+
+sub _max {
+ my $max = shift;
+ foreach my $val (@_) {
+ $max = $val if $max < $val;
+ }
+ return( $max );
+}
+
+sub shrinkwrap {
+ my( $w, $size ) = @_;
+
+ unless( defined $size ) {
+ $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
+ }
+
+ my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
+ $w->configure( -width => $size );
+ $lb->configure( -width => $size );
+}
+
+sub limitheight {
+ my $w = shift;
+ my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
+ $choices_number = 10 if $choices_number > 10;
+ $w->configure(-listheight => $choices_number) if ($choices_number > 0);
+}
+
+sub insert {
+ my $w = shift;
+ $w->Subwidget("slistbox")->insert(@_);
+ if ($w->cget(-autolimitheight)) {
+ $w->limitheight;
+ }
+ if ($w->cget(-autolistwidth)) {
+ $w->updateListWidth(@_[1..$#_]);
+ }
+}
+
+sub delete {
+ my $w = shift;
+ $w->Subwidget("slistbox")->delete(@_);
+ if ($w->cget(-autolimitheight)) {
+ $w->limitheight;
+ }
+ if ($w->cget(-autolistwidth)) {
+ $w->updateListWidth();
+ }
+}
+
+sub updateListWidth {
+ my $w = shift;
+ my @ins = @_;
+ if (!@ins) {
+ @ins = $w->get(0, "end");
+ }
+
+ my $max_width = 0;
+ foreach my $ins (@ins) {
+ my $new_width = $w->fontMeasure($w->cget(-font), $ins);
+ if ($new_width > $max_width) {
+ $max_width = $new_width;
+ }
+ }
+ if ($max_width > 20) { # be sane
+ $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
+ }
+}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Button.pm b/Master/tlpkg/tlperl/lib/Tk/Button.pm
new file mode 100644
index 00000000000..efa597dee14
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Button.pm
@@ -0,0 +1,148 @@
+package Tk::Button;
+# Conversion from Tk4.0 button.tcl competed.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use strict;
+
+require Tk::Widget;
+use base qw(Tk::Widget);
+
+use vars qw($buttonWindow $relief);
+
+Tk::Methods('deselect','flash','invoke','select','toggle');
+
+sub Tk_cmd { \&Tk::button }
+
+Construct Tk::Widget 'Button';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'butDown');
+ $mw->bind($class,'<ButtonRelease-1>', 'butUp');
+ $mw->bind($class,'<space>', 'Invoke');
+ $mw->bind($class,'<Return>', 'Invoke');
+ return $class;
+}
+
+# tkButtonEnter --
+# The procedure below is invoked when the mouse pointer enters a
+# button widget. It records the button we're in and changes the
+# state of the button to active unless the button is disabled.
+#
+# Arguments:
+# w - The name of the widget.
+
+sub Enter
+{
+ my $w = shift;
+ my $E = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->configure('-state' => 'active');
+ $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow)
+ }
+ $Tk::window = $w;
+}
+
+# tkButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to
+# inactive. If we're leaving the button window with a mouse button
+# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
+# button too.
+#
+# Arguments:
+# w - The name of the widget.
+sub Leave
+{
+ my $w = shift;
+ $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
+ $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
+ undef $Tk::window;
+}
+
+# tkButtonDown --
+# The procedure below is invoked when the mouse button is pressed in
+# a button widget. It records the fact that the mouse is in the button,
+# saves the button's relief so it can be restored later, and changes
+# the relief to sunken.
+#
+# Arguments:
+# w - The name of the widget.
+sub butDown
+{
+ my $w = shift;
+ $relief = $w->cget('-relief');
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $buttonWindow = $w;
+ $w->configure('-relief' => 'sunken')
+ }
+}
+
+# tkButtonUp --
+# The procedure below is invoked when the mouse button is released
+# in a button widget. It restores the button's relief and invokes
+# the command as long as the mouse hasn't left the button.
+#
+# Arguments:
+# w - The name of the widget.
+sub butUp
+{
+ my $w = shift;
+ if (defined($buttonWindow) && $buttonWindow == $w)
+ {
+ undef $buttonWindow;
+ $w->configure('-relief' => $relief);
+ if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
+ {
+ $w->invoke;
+ }
+ }
+}
+
+# tkButtonInvoke --
+# The procedure below is called when a button is invoked through
+# the keyboard. It simulate a press of the button via the mouse.
+#
+# Arguments:
+# w - The name of the widget.
+sub Invoke
+{
+ my $w = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ my $oldRelief = $w->cget('-relief');
+ my $oldState = $w->cget('-state');
+ $w->configure('-state' => 'active', '-relief' => 'sunken');
+ $w->idletasks;
+ $w->after(100);
+ $w->configure('-state' => $oldState, '-relief' => $oldRelief);
+ $w->invoke;
+ }
+}
+
+
+
+1;
+
+__END__
+
+
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Camel.xpm b/Master/tlpkg/tlperl/lib/Tk/Camel.xpm
new file mode 100644
index 00000000000..ba33c0149ec
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Camel.xpm
@@ -0,0 +1,41 @@
+/* XPM */
+static char *Camel[] = {
+/* width height num_colors chars_per_pixel */
+" 32 32 2 1",
+/* colors */
+". c #ffffff",
+"# c #7f7f00",
+/* pixels */
+"................................",
+"................................",
+"...................###..........",
+".......####......######.........",
+"....####.##.....########........",
+"....########....#########.......",
+"......######..###########.......",
+"......#####..#############......",
+".....######.##############......",
+".....######.###############.....",
+".....######################.....",
+".....#######################....",
+".....#######################....",
+"......#######################...",
+".......####################.#...",
+"........###################.#...",
+"........###############.###.#...",
+"............#######.###.###.#...",
+"............###.###.##...##.....",
+"............###.###..#...##.....",
+"............##.####..#....#.....",
+"............##.###...#....#.....",
+"............##.##...#.....#.....",
+"............#...#...#.....#.....",
+"............#....#..#.....#.....",
+"............#.....#.#.....#.....",
+"............#.....###.....#.....",
+"...........##....##.#....#......",
+"...........#..............#.....",
+".........###.............#......"
+"................................",
+"................................",
+};
diff --git a/Master/tlpkg/tlperl/lib/Tk/Canvas.pm b/Master/tlpkg/tlperl/lib/Tk/Canvas.pm
new file mode 100644
index 00000000000..210bc30bfc2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Canvas.pm
@@ -0,0 +1,1436 @@
+package Tk::Canvas;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Widget);
+Construct Tk::Widget 'Canvas';
+
+bootstrap Tk::Canvas;
+
+sub Tk_cmd { \&Tk::canvas }
+
+Tk::Methods('addtag','bbox','bind','canvasx','canvasy','coords','create',
+ 'dchars','delete','dtag','find','focus','gettags','icursor',
+ 'index','insert','itemcget','itemconfigure','lower','move',
+ 'postscript','raise','scale','scan','select','type','xview','yview');
+
+use Tk::Submethods ( 'create' => [qw(arc bitmap grid group image line oval
+ polygon rectangle text window)],
+ 'scan' => [qw(mark dragto)],
+ 'select' => [qw(from clear item to)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ );
+
+*CanvasBind = \&Tk::bind;
+*CanvasFocus = \&Tk::focus;
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->XYscrollBind($class);
+ return $class;
+}
+
+sub BalloonInfo
+{
+ my ($canvas,$balloon,$X,$Y,@opt) = @_;
+ my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current'));
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$canvas);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
+ {
+ $balloon->Subclient($tags[0]);
+ foreach my $tag (@tags)
+ {
+ return $info->{$tag} if exists $info->{$tag};
+ }
+ return '';
+ }
+ return $info;
+ }
+}
+
+sub get_corners
+{
+ my $c = shift;
+ my(@xview) = $c->xview;
+ my(@yview) = $c->yview;
+ my(@scrollregion) = @{$c->cget(-scrollregion)};
+ return (
+ $xview[0] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0],
+ $yview[0] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1],
+ $xview[1] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0],
+ $yview[1] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1],
+ );
+}
+
+# List of adobe glyph names. Converted from glyphlist.txt, downloaded
+# from Adobe
+
+$Tk::psglyphs = {qw(
+ 0020 space
+ 0021 exclam
+ 0022 quotedbl
+ 0023 numbersign
+ 0024 dollar
+ 0025 percent
+ 0026 ampersand
+ 0027 quotesingle
+ 0028 parenleft
+ 0029 parenright
+ 002A asterisk
+ 002B plus
+ 002C comma
+ 002D hyphen
+ 002E period
+ 002F slash
+ 0030 zero
+ 0031 one
+ 0032 two
+ 0033 three
+ 0034 four
+ 0035 five
+ 0036 six
+ 0037 seven
+ 0038 eight
+ 0039 nine
+ 003A colon
+ 003B semicolon
+ 003C less
+ 003D equal
+ 003E greater
+ 003F question
+ 0040 at
+ 0041 A
+ 0042 B
+ 0043 C
+ 0044 D
+ 0045 E
+ 0046 F
+ 0047 G
+ 0048 H
+ 0049 I
+ 004A J
+ 004B K
+ 004C L
+ 004D M
+ 004E N
+ 004F O
+ 0050 P
+ 0051 Q
+ 0052 R
+ 0053 S
+ 0054 T
+ 0055 U
+ 0056 V
+ 0057 W
+ 0058 X
+ 0059 Y
+ 005A Z
+ 005B bracketleft
+ 005C backslash
+ 005D bracketright
+ 005E asciicircum
+ 005F underscore
+ 0060 grave
+ 0061 a
+ 0062 b
+ 0063 c
+ 0064 d
+ 0065 e
+ 0066 f
+ 0067 g
+ 0068 h
+ 0069 i
+ 006A j
+ 006B k
+ 006C l
+ 006D m
+ 006E n
+ 006F o
+ 0070 p
+ 0071 q
+ 0072 r
+ 0073 s
+ 0074 t
+ 0075 u
+ 0076 v
+ 0077 w
+ 0078 x
+ 0079 y
+ 007A z
+ 007B braceleft
+ 007C bar
+ 007D braceright
+ 007E asciitilde
+ 00A0 space
+ 00A1 exclamdown
+ 00A2 cent
+ 00A3 sterling
+ 00A4 currency
+ 00A5 yen
+ 00A6 brokenbar
+ 00A7 section
+ 00A8 dieresis
+ 00A9 copyright
+ 00AA ordfeminine
+ 00AB guillemotleft
+ 00AC logicalnot
+ 00AD hyphen
+ 00AE registered
+ 00AF macron
+ 00B0 degree
+ 00B1 plusminus
+ 00B2 twosuperior
+ 00B3 threesuperior
+ 00B4 acute
+ 00B5 mu
+ 00B6 paragraph
+ 00B7 periodcentered
+ 00B8 cedilla
+ 00B9 onesuperior
+ 00BA ordmasculine
+ 00BB guillemotright
+ 00BC onequarter
+ 00BD onehalf
+ 00BE threequarters
+ 00BF questiondown
+ 00C0 Agrave
+ 00C1 Aacute
+ 00C2 Acircumflex
+ 00C3 Atilde
+ 00C4 Adieresis
+ 00C5 Aring
+ 00C6 AE
+ 00C7 Ccedilla
+ 00C8 Egrave
+ 00C9 Eacute
+ 00CA Ecircumflex
+ 00CB Edieresis
+ 00CC Igrave
+ 00CD Iacute
+ 00CE Icircumflex
+ 00CF Idieresis
+ 00D0 Eth
+ 00D1 Ntilde
+ 00D2 Ograve
+ 00D3 Oacute
+ 00D4 Ocircumflex
+ 00D5 Otilde
+ 00D6 Odieresis
+ 00D7 multiply
+ 00D8 Oslash
+ 00D9 Ugrave
+ 00DA Uacute
+ 00DB Ucircumflex
+ 00DC Udieresis
+ 00DD Yacute
+ 00DE Thorn
+ 00DF germandbls
+ 00E0 agrave
+ 00E1 aacute
+ 00E2 acircumflex
+ 00E3 atilde
+ 00E4 adieresis
+ 00E5 aring
+ 00E6 ae
+ 00E7 ccedilla
+ 00E8 egrave
+ 00E9 eacute
+ 00EA ecircumflex
+ 00EB edieresis
+ 00EC igrave
+ 00ED iacute
+ 00EE icircumflex
+ 00EF idieresis
+ 00F0 eth
+ 00F1 ntilde
+ 00F2 ograve
+ 00F3 oacute
+ 00F4 ocircumflex
+ 00F5 otilde
+ 00F6 odieresis
+ 00F7 divide
+ 00F8 oslash
+ 00F9 ugrave
+ 00FA uacute
+ 00FB ucircumflex
+ 00FC udieresis
+ 00FD yacute
+ 00FE thorn
+ 00FF ydieresis
+ 0100 Amacron
+ 0101 amacron
+ 0102 Abreve
+ 0103 abreve
+ 0104 Aogonek
+ 0105 aogonek
+ 0106 Cacute
+ 0107 cacute
+ 0108 Ccircumflex
+ 0109 ccircumflex
+ 010A Cdotaccent
+ 010B cdotaccent
+ 010C Ccaron
+ 010D ccaron
+ 010E Dcaron
+ 010F dcaron
+ 0110 Dcroat
+ 0111 dcroat
+ 0112 Emacron
+ 0113 emacron
+ 0114 Ebreve
+ 0115 ebreve
+ 0116 Edotaccent
+ 0117 edotaccent
+ 0118 Eogonek
+ 0119 eogonek
+ 011A Ecaron
+ 011B ecaron
+ 011C Gcircumflex
+ 011D gcircumflex
+ 011E Gbreve
+ 011F gbreve
+ 0120 Gdotaccent
+ 0121 gdotaccent
+ 0122 Gcommaaccent
+ 0123 gcommaaccent
+ 0124 Hcircumflex
+ 0125 hcircumflex
+ 0126 Hbar
+ 0127 hbar
+ 0128 Itilde
+ 0129 itilde
+ 012A Imacron
+ 012B imacron
+ 012C Ibreve
+ 012D ibreve
+ 012E Iogonek
+ 012F iogonek
+ 0130 Idotaccent
+ 0131 dotlessi
+ 0132 IJ
+ 0133 ij
+ 0134 Jcircumflex
+ 0135 jcircumflex
+ 0136 Kcommaaccent
+ 0137 kcommaaccent
+ 0138 kgreenlandic
+ 0139 Lacute
+ 013A lacute
+ 013B Lcommaaccent
+ 013C lcommaaccent
+ 013D Lcaron
+ 013E lcaron
+ 013F Ldot
+ 0140 ldot
+ 0141 Lslash
+ 0142 lslash
+ 0143 Nacute
+ 0144 nacute
+ 0145 Ncommaaccent
+ 0146 ncommaaccent
+ 0147 Ncaron
+ 0148 ncaron
+ 0149 napostrophe
+ 014A Eng
+ 014B eng
+ 014C Omacron
+ 014D omacron
+ 014E Obreve
+ 014F obreve
+ 0150 Ohungarumlaut
+ 0151 ohungarumlaut
+ 0152 OE
+ 0153 oe
+ 0154 Racute
+ 0155 racute
+ 0156 Rcommaaccent
+ 0157 rcommaaccent
+ 0158 Rcaron
+ 0159 rcaron
+ 015A Sacute
+ 015B sacute
+ 015C Scircumflex
+ 015D scircumflex
+ 015E Scedilla
+ 015F scedilla
+ 0160 Scaron
+ 0161 scaron
+ 0162 Tcommaaccent
+ 0163 tcommaaccent
+ 0164 Tcaron
+ 0165 tcaron
+ 0166 Tbar
+ 0167 tbar
+ 0168 Utilde
+ 0169 utilde
+ 016A Umacron
+ 016B umacron
+ 016C Ubreve
+ 016D ubreve
+ 016E Uring
+ 016F uring
+ 0170 Uhungarumlaut
+ 0171 uhungarumlaut
+ 0172 Uogonek
+ 0173 uogonek
+ 0174 Wcircumflex
+ 0175 wcircumflex
+ 0176 Ycircumflex
+ 0177 ycircumflex
+ 0178 Ydieresis
+ 0179 Zacute
+ 017A zacute
+ 017B Zdotaccent
+ 017C zdotaccent
+ 017D Zcaron
+ 017E zcaron
+ 017F longs
+ 0192 florin
+ 01A0 Ohorn
+ 01A1 ohorn
+ 01AF Uhorn
+ 01B0 uhorn
+ 01E6 Gcaron
+ 01E7 gcaron
+ 01FA Aringacute
+ 01FB aringacute
+ 01FC AEacute
+ 01FD aeacute
+ 01FE Oslashacute
+ 01FF oslashacute
+ 0218 Scommaaccent
+ 0219 scommaaccent
+ 021A Tcommaaccent
+ 021B tcommaaccent
+ 02BC afii57929
+ 02BD afii64937
+ 02C6 circumflex
+ 02C7 caron
+ 02C9 macron
+ 02D8 breve
+ 02D9 dotaccent
+ 02DA ring
+ 02DB ogonek
+ 02DC tilde
+ 02DD hungarumlaut
+ 0300 gravecomb
+ 0301 acutecomb
+ 0303 tildecomb
+ 0309 hookabovecomb
+ 0323 dotbelowcomb
+ 0384 tonos
+ 0385 dieresistonos
+ 0386 Alphatonos
+ 0387 anoteleia
+ 0388 Epsilontonos
+ 0389 Etatonos
+ 038A Iotatonos
+ 038C Omicrontonos
+ 038E Upsilontonos
+ 038F Omegatonos
+ 0390 iotadieresistonos
+ 0391 Alpha
+ 0392 Beta
+ 0393 Gamma
+ 0394 Delta
+ 0395 Epsilon
+ 0396 Zeta
+ 0397 Eta
+ 0398 Theta
+ 0399 Iota
+ 039A Kappa
+ 039B Lambda
+ 039C Mu
+ 039D Nu
+ 039E Xi
+ 039F Omicron
+ 03A0 Pi
+ 03A1 Rho
+ 03A3 Sigma
+ 03A4 Tau
+ 03A5 Upsilon
+ 03A6 Phi
+ 03A7 Chi
+ 03A8 Psi
+ 03A9 Omega
+ 03AA Iotadieresis
+ 03AB Upsilondieresis
+ 03AC alphatonos
+ 03AD epsilontonos
+ 03AE etatonos
+ 03AF iotatonos
+ 03B0 upsilondieresistonos
+ 03B1 alpha
+ 03B2 beta
+ 03B3 gamma
+ 03B4 delta
+ 03B5 epsilon
+ 03B6 zeta
+ 03B7 eta
+ 03B8 theta
+ 03B9 iota
+ 03BA kappa
+ 03BB lambda
+ 03BC mu
+ 03BD nu
+ 03BE xi
+ 03BF omicron
+ 03C0 pi
+ 03C1 rho
+ 03C2 sigma1
+ 03C3 sigma
+ 03C4 tau
+ 03C5 upsilon
+ 03C6 phi
+ 03C7 chi
+ 03C8 psi
+ 03C9 omega
+ 03CA iotadieresis
+ 03CB upsilondieresis
+ 03CC omicrontonos
+ 03CD upsilontonos
+ 03CE omegatonos
+ 03D1 theta1
+ 03D2 Upsilon1
+ 03D5 phi1
+ 03D6 omega1
+ 0401 afii10023
+ 0402 afii10051
+ 0403 afii10052
+ 0404 afii10053
+ 0405 afii10054
+ 0406 afii10055
+ 0407 afii10056
+ 0408 afii10057
+ 0409 afii10058
+ 040A afii10059
+ 040B afii10060
+ 040C afii10061
+ 040E afii10062
+ 040F afii10145
+ 0410 afii10017
+ 0411 afii10018
+ 0412 afii10019
+ 0413 afii10020
+ 0414 afii10021
+ 0415 afii10022
+ 0416 afii10024
+ 0417 afii10025
+ 0418 afii10026
+ 0419 afii10027
+ 041A afii10028
+ 041B afii10029
+ 041C afii10030
+ 041D afii10031
+ 041E afii10032
+ 041F afii10033
+ 0420 afii10034
+ 0421 afii10035
+ 0422 afii10036
+ 0423 afii10037
+ 0424 afii10038
+ 0425 afii10039
+ 0426 afii10040
+ 0427 afii10041
+ 0428 afii10042
+ 0429 afii10043
+ 042A afii10044
+ 042B afii10045
+ 042C afii10046
+ 042D afii10047
+ 042E afii10048
+ 042F afii10049
+ 0430 afii10065
+ 0431 afii10066
+ 0432 afii10067
+ 0433 afii10068
+ 0434 afii10069
+ 0435 afii10070
+ 0436 afii10072
+ 0437 afii10073
+ 0438 afii10074
+ 0439 afii10075
+ 043A afii10076
+ 043B afii10077
+ 043C afii10078
+ 043D afii10079
+ 043E afii10080
+ 043F afii10081
+ 0440 afii10082
+ 0441 afii10083
+ 0442 afii10084
+ 0443 afii10085
+ 0444 afii10086
+ 0445 afii10087
+ 0446 afii10088
+ 0447 afii10089
+ 0448 afii10090
+ 0449 afii10091
+ 044A afii10092
+ 044B afii10093
+ 044C afii10094
+ 044D afii10095
+ 044E afii10096
+ 044F afii10097
+ 0451 afii10071
+ 0452 afii10099
+ 0453 afii10100
+ 0454 afii10101
+ 0455 afii10102
+ 0456 afii10103
+ 0457 afii10104
+ 0458 afii10105
+ 0459 afii10106
+ 045A afii10107
+ 045B afii10108
+ 045C afii10109
+ 045E afii10110
+ 045F afii10193
+ 0462 afii10146
+ 0463 afii10194
+ 0472 afii10147
+ 0473 afii10195
+ 0474 afii10148
+ 0475 afii10196
+ 0490 afii10050
+ 0491 afii10098
+ 04D9 afii10846
+ 05B0 afii57799
+ 05B1 afii57801
+ 05B2 afii57800
+ 05B3 afii57802
+ 05B4 afii57793
+ 05B5 afii57794
+ 05B6 afii57795
+ 05B7 afii57798
+ 05B8 afii57797
+ 05B9 afii57806
+ 05BB afii57796
+ 05BC afii57807
+ 05BD afii57839
+ 05BE afii57645
+ 05BF afii57841
+ 05C0 afii57842
+ 05C1 afii57804
+ 05C2 afii57803
+ 05C3 afii57658
+ 05D0 afii57664
+ 05D1 afii57665
+ 05D2 afii57666
+ 05D3 afii57667
+ 05D4 afii57668
+ 05D5 afii57669
+ 05D6 afii57670
+ 05D7 afii57671
+ 05D8 afii57672
+ 05D9 afii57673
+ 05DA afii57674
+ 05DB afii57675
+ 05DC afii57676
+ 05DD afii57677
+ 05DE afii57678
+ 05DF afii57679
+ 05E0 afii57680
+ 05E1 afii57681
+ 05E2 afii57682
+ 05E3 afii57683
+ 05E4 afii57684
+ 05E5 afii57685
+ 05E6 afii57686
+ 05E7 afii57687
+ 05E8 afii57688
+ 05E9 afii57689
+ 05EA afii57690
+ 05F0 afii57716
+ 05F1 afii57717
+ 05F2 afii57718
+ 060C afii57388
+ 061B afii57403
+ 061F afii57407
+ 0621 afii57409
+ 0622 afii57410
+ 0623 afii57411
+ 0624 afii57412
+ 0625 afii57413
+ 0626 afii57414
+ 0627 afii57415
+ 0628 afii57416
+ 0629 afii57417
+ 062A afii57418
+ 062B afii57419
+ 062C afii57420
+ 062D afii57421
+ 062E afii57422
+ 062F afii57423
+ 0630 afii57424
+ 0631 afii57425
+ 0632 afii57426
+ 0633 afii57427
+ 0634 afii57428
+ 0635 afii57429
+ 0636 afii57430
+ 0637 afii57431
+ 0638 afii57432
+ 0639 afii57433
+ 063A afii57434
+ 0640 afii57440
+ 0641 afii57441
+ 0642 afii57442
+ 0643 afii57443
+ 0644 afii57444
+ 0645 afii57445
+ 0646 afii57446
+ 0647 afii57470
+ 0648 afii57448
+ 0649 afii57449
+ 064A afii57450
+ 064B afii57451
+ 064C afii57452
+ 064D afii57453
+ 064E afii57454
+ 064F afii57455
+ 0650 afii57456
+ 0651 afii57457
+ 0652 afii57458
+ 0660 afii57392
+ 0661 afii57393
+ 0662 afii57394
+ 0663 afii57395
+ 0664 afii57396
+ 0665 afii57397
+ 0666 afii57398
+ 0667 afii57399
+ 0668 afii57400
+ 0669 afii57401
+ 066A afii57381
+ 066D afii63167
+ 0679 afii57511
+ 067E afii57506
+ 0686 afii57507
+ 0688 afii57512
+ 0691 afii57513
+ 0698 afii57508
+ 06A4 afii57505
+ 06AF afii57509
+ 06BA afii57514
+ 06D2 afii57519
+ 06D5 afii57534
+ 1E80 Wgrave
+ 1E81 wgrave
+ 1E82 Wacute
+ 1E83 wacute
+ 1E84 Wdieresis
+ 1E85 wdieresis
+ 1EF2 Ygrave
+ 1EF3 ygrave
+ 200C afii61664
+ 200D afii301
+ 200E afii299
+ 200F afii300
+ 2012 figuredash
+ 2013 endash
+ 2014 emdash
+ 2015 afii00208
+ 2017 underscoredbl
+ 2018 quoteleft
+ 2019 quoteright
+ 201A quotesinglbase
+ 201B quotereversed
+ 201C quotedblleft
+ 201D quotedblright
+ 201E quotedblbase
+ 2020 dagger
+ 2021 daggerdbl
+ 2022 bullet
+ 2024 onedotenleader
+ 2025 twodotenleader
+ 2026 ellipsis
+ 202C afii61573
+ 202D afii61574
+ 202E afii61575
+ 2030 perthousand
+ 2032 minute
+ 2033 second
+ 2039 guilsinglleft
+ 203A guilsinglright
+ 203C exclamdbl
+ 2044 fraction
+ 2070 zerosuperior
+ 2074 foursuperior
+ 2075 fivesuperior
+ 2076 sixsuperior
+ 2077 sevensuperior
+ 2078 eightsuperior
+ 2079 ninesuperior
+ 207D parenleftsuperior
+ 207E parenrightsuperior
+ 207F nsuperior
+ 2080 zeroinferior
+ 2081 oneinferior
+ 2082 twoinferior
+ 2083 threeinferior
+ 2084 fourinferior
+ 2085 fiveinferior
+ 2086 sixinferior
+ 2087 seveninferior
+ 2088 eightinferior
+ 2089 nineinferior
+ 208D parenleftinferior
+ 208E parenrightinferior
+ 20A1 colonmonetary
+ 20A3 franc
+ 20A4 lira
+ 20A7 peseta
+ 20AA afii57636
+ 20AB dong
+ 20AC Euro
+ 2105 afii61248
+ 2111 Ifraktur
+ 2113 afii61289
+ 2116 afii61352
+ 2118 weierstrass
+ 211C Rfraktur
+ 211E prescription
+ 2122 trademark
+ 2126 Omega
+ 212E estimated
+ 2135 aleph
+ 2153 onethird
+ 2154 twothirds
+ 215B oneeighth
+ 215C threeeighths
+ 215D fiveeighths
+ 215E seveneighths
+ 2190 arrowleft
+ 2191 arrowup
+ 2192 arrowright
+ 2193 arrowdown
+ 2194 arrowboth
+ 2195 arrowupdn
+ 21A8 arrowupdnbse
+ 21B5 carriagereturn
+ 21D0 arrowdblleft
+ 21D1 arrowdblup
+ 21D2 arrowdblright
+ 21D3 arrowdbldown
+ 21D4 arrowdblboth
+ 2200 universal
+ 2202 partialdiff
+ 2203 existential
+ 2205 emptyset
+ 2206 Delta
+ 2207 gradient
+ 2208 element
+ 2209 notelement
+ 220B suchthat
+ 220F product
+ 2211 summation
+ 2212 minus
+ 2215 fraction
+ 2217 asteriskmath
+ 2219 periodcentered
+ 221A radical
+ 221D proportional
+ 221E infinity
+ 221F orthogonal
+ 2220 angle
+ 2227 logicaland
+ 2228 logicalor
+ 2229 intersection
+ 222A union
+ 222B integral
+ 2234 therefore
+ 223C similar
+ 2245 congruent
+ 2248 approxequal
+ 2260 notequal
+ 2261 equivalence
+ 2264 lessequal
+ 2265 greaterequal
+ 2282 propersubset
+ 2283 propersuperset
+ 2284 notsubset
+ 2286 reflexsubset
+ 2287 reflexsuperset
+ 2295 circleplus
+ 2297 circlemultiply
+ 22A5 perpendicular
+ 22C5 dotmath
+ 2302 house
+ 2310 revlogicalnot
+ 2320 integraltp
+ 2321 integralbt
+ 2329 angleleft
+ 232A angleright
+ 2500 SF100000
+ 2502 SF110000
+ 250C SF010000
+ 2510 SF030000
+ 2514 SF020000
+ 2518 SF040000
+ 251C SF080000
+ 2524 SF090000
+ 252C SF060000
+ 2534 SF070000
+ 253C SF050000
+ 2550 SF430000
+ 2551 SF240000
+ 2552 SF510000
+ 2553 SF520000
+ 2554 SF390000
+ 2555 SF220000
+ 2556 SF210000
+ 2557 SF250000
+ 2558 SF500000
+ 2559 SF490000
+ 255A SF380000
+ 255B SF280000
+ 255C SF270000
+ 255D SF260000
+ 255E SF360000
+ 255F SF370000
+ 2560 SF420000
+ 2561 SF190000
+ 2562 SF200000
+ 2563 SF230000
+ 2564 SF470000
+ 2565 SF480000
+ 2566 SF410000
+ 2567 SF450000
+ 2568 SF460000
+ 2569 SF400000
+ 256A SF540000
+ 256B SF530000
+ 256C SF440000
+ 2580 upblock
+ 2584 dnblock
+ 2588 block
+ 258C lfblock
+ 2590 rtblock
+ 2591 ltshade
+ 2592 shade
+ 2593 dkshade
+ 25A0 filledbox
+ 25A1 H22073
+ 25AA H18543
+ 25AB H18551
+ 25AC filledrect
+ 25B2 triagup
+ 25BA triagrt
+ 25BC triagdn
+ 25C4 triaglf
+ 25CA lozenge
+ 25CB circle
+ 25CF H18533
+ 25D8 invbullet
+ 25D9 invcircle
+ 25E6 openbullet
+ 263A smileface
+ 263B invsmileface
+ 263C sun
+ 2640 female
+ 2642 male
+ 2660 spade
+ 2663 club
+ 2665 heart
+ 2666 diamond
+ 266A musicalnote
+ 266B musicalnotedbl
+ F6BE dotlessj
+ F6BF LL
+ F6C0 ll
+ F6C1 Scedilla
+ F6C2 scedilla
+ F6C3 commaaccent
+ F6C4 afii10063
+ F6C5 afii10064
+ F6C6 afii10192
+ F6C7 afii10831
+ F6C8 afii10832
+ F6C9 Acute
+ F6CA Caron
+ F6CB Dieresis
+ F6CC DieresisAcute
+ F6CD DieresisGrave
+ F6CE Grave
+ F6CF Hungarumlaut
+ F6D0 Macron
+ F6D1 cyrBreve
+ F6D2 cyrFlex
+ F6D3 dblGrave
+ F6D4 cyrbreve
+ F6D5 cyrflex
+ F6D6 dblgrave
+ F6D7 dieresisacute
+ F6D8 dieresisgrave
+ F6D9 copyrightserif
+ F6DA registerserif
+ F6DB trademarkserif
+ F6DC onefitted
+ F6DD rupiah
+ F6DE threequartersemdash
+ F6DF centinferior
+ F6E0 centsuperior
+ F6E1 commainferior
+ F6E2 commasuperior
+ F6E3 dollarinferior
+ F6E4 dollarsuperior
+ F6E5 hypheninferior
+ F6E6 hyphensuperior
+ F6E7 periodinferior
+ F6E8 periodsuperior
+ F6E9 asuperior
+ F6EA bsuperior
+ F6EB dsuperior
+ F6EC esuperior
+ F6ED isuperior
+ F6EE lsuperior
+ F6EF msuperior
+ F6F0 osuperior
+ F6F1 rsuperior
+ F6F2 ssuperior
+ F6F3 tsuperior
+ F6F4 Brevesmall
+ F6F5 Caronsmall
+ F6F6 Circumflexsmall
+ F6F7 Dotaccentsmall
+ F6F8 Hungarumlautsmall
+ F6F9 Lslashsmall
+ F6FA OEsmall
+ F6FB Ogoneksmall
+ F6FC Ringsmall
+ F6FD Scaronsmall
+ F6FE Tildesmall
+ F6FF Zcaronsmall
+ F721 exclamsmall
+ F724 dollaroldstyle
+ F726 ampersandsmall
+ F730 zerooldstyle
+ F731 oneoldstyle
+ F732 twooldstyle
+ F733 threeoldstyle
+ F734 fouroldstyle
+ F735 fiveoldstyle
+ F736 sixoldstyle
+ F737 sevenoldstyle
+ F738 eightoldstyle
+ F739 nineoldstyle
+ F73F questionsmall
+ F760 Gravesmall
+ F761 Asmall
+ F762 Bsmall
+ F763 Csmall
+ F764 Dsmall
+ F765 Esmall
+ F766 Fsmall
+ F767 Gsmall
+ F768 Hsmall
+ F769 Ismall
+ F76A Jsmall
+ F76B Ksmall
+ F76C Lsmall
+ F76D Msmall
+ F76E Nsmall
+ F76F Osmall
+ F770 Psmall
+ F771 Qsmall
+ F772 Rsmall
+ F773 Ssmall
+ F774 Tsmall
+ F775 Usmall
+ F776 Vsmall
+ F777 Wsmall
+ F778 Xsmall
+ F779 Ysmall
+ F77A Zsmall
+ F7A1 exclamdownsmall
+ F7A2 centoldstyle
+ F7A8 Dieresissmall
+ F7AF Macronsmall
+ F7B4 Acutesmall
+ F7B8 Cedillasmall
+ F7BF questiondownsmall
+ F7E0 Agravesmall
+ F7E1 Aacutesmall
+ F7E2 Acircumflexsmall
+ F7E3 Atildesmall
+ F7E4 Adieresissmall
+ F7E5 Aringsmall
+ F7E6 AEsmall
+ F7E7 Ccedillasmall
+ F7E8 Egravesmall
+ F7E9 Eacutesmall
+ F7EA Ecircumflexsmall
+ F7EB Edieresissmall
+ F7EC Igravesmall
+ F7ED Iacutesmall
+ F7EE Icircumflexsmall
+ F7EF Idieresissmall
+ F7F0 Ethsmall
+ F7F1 Ntildesmall
+ F7F2 Ogravesmall
+ F7F3 Oacutesmall
+ F7F4 Ocircumflexsmall
+ F7F5 Otildesmall
+ F7F6 Odieresissmall
+ F7F8 Oslashsmall
+ F7F9 Ugravesmall
+ F7FA Uacutesmall
+ F7FB Ucircumflexsmall
+ F7FC Udieresissmall
+ F7FD Yacutesmall
+ F7FE Thornsmall
+ F7FF Ydieresissmall
+ F8E5 radicalex
+ F8E6 arrowvertex
+ F8E7 arrowhorizex
+ F8E8 registersans
+ F8E9 copyrightsans
+ F8EA trademarksans
+ F8EB parenlefttp
+ F8EC parenleftex
+ F8ED parenleftbt
+ F8EE bracketlefttp
+ F8EF bracketleftex
+ F8F0 bracketleftbt
+ F8F1 bracelefttp
+ F8F2 braceleftmid
+ F8F3 braceleftbt
+ F8F4 braceex
+ F8F5 integralex
+ F8F6 parenrighttp
+ F8F7 parenrightex
+ F8F8 parenrightbt
+ F8F9 bracketrighttp
+ F8FA bracketrightex
+ F8FB bracketrightbt
+ F8FC bracerighttp
+ F8FD bracerightmid
+ F8FE bracerightbt
+ FB00 ff
+ FB01 fi
+ FB02 fl
+ FB03 ffi
+ FB04 ffl
+ FB1F afii57705
+ FB2A afii57694
+ FB2B afii57695
+ FB35 afii57723
+ FB4B afii57700
+)};
+
+
+sub CreatePostscriptEncoding
+{
+ my ($encoding) = @_;
+ my $result = "/CurrentEncoding \[\n";
+ for (my $i = 0; $i < 256; $i += 8)
+ {
+ for (my $j = 0; $j < 8; $j++)
+ {
+ my $ch;
+ Tk::catch { $ch = $encoding->decode(chr($i+$j),1) };
+ if ($@)
+ {
+ $result .= '/space';
+ }
+ else
+ {
+ my $hexcode = sprintf("%04X",ord($ch));
+ $result .= '/'.((exists $Tk::psglyphs->{$hexcode}) ? $Tk::psglyphs->{$hexcode} : 'space');
+ }
+ }
+ $result .= "\n";
+ }
+ $result .= "\] def\n";
+ return $result;
+}
+
+# precalculate entire prolog when this file is loaded
+# (to speed things up)
+$Tk::ps_preamable = "%%BeginProlog\n".
+ CreatePostscriptEncoding(Tk::SystemEncoding()). <<'END';
+50 dict begin
+% This is a standard prolog for Postscript generated by Tk's canvas
+% widget.
+% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#12 $
+
+% The definitions below just define all of the variables used in
+% any of the procedures here. This is needed for obscure reasons
+% explained on p. 716 of the Postscript manual (Section H.2.7,
+% "Initializing Variables," in the section on Encapsulated Postscript).
+
+/baseline 0 def
+/stipimage 0 def
+/height 0 def
+/justify 0 def
+/lineLength 0 def
+/spacing 0 def
+/stipple 0 def
+/strings 0 def
+/xoffset 0 def
+/yoffset 0 def
+/tmpstip null def
+
+
+/cstringshow {
+ {
+ dup type /stringtype eq
+ { show } { glyphshow }
+ ifelse
+ }
+ forall
+} bind def
+
+
+
+/cstringwidth {
+ 0 exch 0 exch
+ {
+ dup type /stringtype eq
+ { stringwidth } {
+ currentfont /Encoding get exch 1 exch put (\001) stringwidth
+ }
+ ifelse
+ exch 3 1 roll add 3 1 roll add exch
+ }
+ forall
+} bind def
+
+% font ISOEncode font
+% This procedure changes the encoding of a font from the default
+% Postscript encoding to current system encoding. It's typically invoked just
+% before invoking "setfont". The body of this procedure comes from
+% Section 5.6.1 of the Postscript book.
+
+/ISOEncode {
+ dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding CurrentEncoding def
+ currentdict
+ end
+
+ % I'm not sure why it's necessary to use "definefont" on this new
+ % font, but it seems to be important; just use the name "Temporary"
+ % for the font.
+
+ /Temporary exch definefont
+} bind def
+
+% StrokeClip
+%
+% This procedure converts the current path into a clip area under
+% the assumption of stroking. It's a bit tricky because some Postscript
+% interpreters get errors during strokepath for dashed lines. If
+% this happens then turn off dashes and try again.
+
+/StrokeClip {
+ {strokepath} stopped {
+ (This Postscript printer gets limitcheck overflows when) =
+ (stippling dashed lines; lines will be printed solid instead.) =
+ [] 0 setdash strokepath} if
+ clip
+} bind def
+
+% desiredSize EvenPixels closestSize
+%
+% The procedure below is used for stippling. Given the optimal size
+% of a dot in a stipple pattern in the current user coordinate system,
+% compute the closest size that is an exact multiple of the device's
+% pixel size. This allows stipple patterns to be displayed without
+% aliasing effects.
+
+/EvenPixels {
+ % Compute exact number of device pixels per stipple dot.
+ dup 0 matrix currentmatrix dtransform
+ dup mul exch dup mul add sqrt
+
+ % Round to an integer, make sure the number is at least 1, and compute
+ % user coord distance corresponding to this.
+ dup round dup 1 lt {pop 1} if
+ exch div mul
+} bind def
+
+% width height string StippleFill --
+%
+% Given a path already set up and a clipping region generated from
+% it, this procedure will fill the clipping region with a stipple
+% pattern. "String" contains a proper image description of the
+% stipple pattern and "width" and "height" give its dimensions. Each
+% stipple dot is assumed to be about one unit across in the current
+% user coordinate system. This procedure trashes the graphics state.
+
+/StippleFill {
+ % The following code is needed to work around a NeWSprint bug.
+
+ /tmpstip 1 index def
+
+ % Change the scaling so that one user unit in user coordinates
+ % corresponds to the size of one stipple dot.
+ 1 EvenPixels dup scale
+
+ % Compute the bounding box occupied by the path (which is now
+ % the clipping region), and round the lower coordinates down
+ % to the nearest starting point for the stipple pattern. Be
+ % careful about negative numbers, since the rounding works
+ % differently on them.
+
+ pathbbox
+ 4 2 roll
+ 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
+ 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
+
+ % Stack now: width height string y1 y2 x1 x2
+ % Below is a doubly-nested for loop to iterate across this area
+ % in units of the stipple pattern size, going up columns then
+ % across rows, blasting out a stipple-pattern-sized rectangle at
+ % each position
+
+ 6 index exch {
+ 2 index 5 index 3 index {
+ % Stack now: width height string y1 y2 x y
+
+ gsave
+ 1 index exch translate
+ 5 index 5 index true matrix tmpstip imagemask
+ grestore
+ } for
+ pop
+ } for
+ pop pop pop pop pop
+} bind def
+
+% -- AdjustColor --
+% Given a color value already set for output by the caller, adjusts
+% that value to a grayscale or mono value if requested by the CL
+% variable.
+
+/AdjustColor {
+ CL 2 lt {
+ currentgray
+ CL 0 eq {
+ .5 lt {0} {1} ifelse
+ } if
+ setgray
+ } if
+} bind def
+
+% x y strings spacing xoffset yoffset justify stipple DrawText --
+% This procedure does all of the real work of drawing text. The
+% color and font must already have been set by the caller, and the
+% following arguments must be on the stack:
+%
+% x, y - Coordinates at which to draw text.
+% strings - An array of strings, one for each line of the text item,
+% in order from top to bottom.
+% spacing - Spacing between lines.
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.
+% stipple - Boolean value indicating whether or not text is to be
+% drawn in stippled fashion. If text is stippled,
+% procedure StippleText must have been defined to call
+% StippleFill in the right way.
+%
+% Also, when this procedure is invoked, the color and font must already
+% have been set for the text.
+
+/DrawText {
+ /stipple exch def
+ /justify exch def
+ /yoffset exch def
+ /xoffset exch def
+ /spacing exch def
+ /strings exch def
+
+ % First scan through all of the text to find the widest line.
+
+ /lineLength 0 def
+ strings {
+ cstringwidth pop
+ dup lineLength gt {/lineLength exch def} {pop} ifelse
+ newpath
+ } forall
+
+ % Compute the baseline offset and the actual font height.
+
+ 0 0 moveto (TXygqPZ) false charpath
+ pathbbox dup /baseline exch def
+ exch pop exch sub /height exch def pop
+ newpath
+
+ % Translate coordinates first so that the origin is at the upper-left
+ % corner of the text's bounding box. Remember that x and y for
+ % positioning are still on the stack.
+
+ translate
+ lineLength xoffset mul
+ strings length 1 sub spacing mul height add yoffset mul translate
+
+ % Now use the baseline and justification information to translate so
+ % that the origin is at the baseline and positioning point for the
+ % first line of text.
+
+ justify lineLength mul baseline neg translate
+
+ % Iterate over each of the lines to output it. For each line,
+ % compute its width again so it can be properly justified, then
+ % display it.
+
+ strings {
+ dup cstringwidth pop
+ justify neg mul 0 moveto
+ stipple {
+
+
+ % The text is stippled, so turn it into a path and print
+ % by calling StippledText, which in turn calls StippleFill.
+ % Unfortunately, many Postscript interpreters will get
+ % overflow errors if we try to do the whole string at
+ % once, so do it a character at a time.
+
+ gsave
+ /char (X) def
+ {
+ dup type /stringtype eq {
+ % This segment is a string.
+ {
+ char 0 3 -1 roll put
+ currentpoint
+ gsave
+ char true charpath clip StippleText
+ grestore
+ char stringwidth translate
+ moveto
+ } forall
+ } {
+ % This segment is glyph name
+ % Temporary override
+ currentfont /Encoding get exch 1 exch put
+ currentpoint
+ gsave (\001) true charpath clip StippleText
+ grestore
+ (\001) stringwidth translate
+ moveto
+ } ifelse
+ } forall
+ grestore
+ } {cstringshow} ifelse
+ 0 spacing neg translate
+ } forall
+} bind def
+
+%%EndProlog
+END
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm b/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm
new file mode 100644
index 00000000000..491d8cd2444
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Checkbutton.pm
@@ -0,0 +1,42 @@
+package Tk::Checkbutton;
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Widget;
+require Tk::Button;
+
+use base qw(Tk::Button);
+
+Construct Tk::Widget 'Checkbutton';
+
+sub Tk_cmd { \&Tk::checkbutton }
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm b/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm
new file mode 100644
index 00000000000..b0eb0ea2b07
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Clipboard.pm
@@ -0,0 +1,122 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Clipboard;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use AutoLoader qw(AUTOLOAD);
+use Tk qw(catch);
+
+sub clipEvents
+{
+ return qw[Copy Cut Paste];
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ foreach my $op ($class->clipEvents)
+ {
+ $mw->Tk::bind($class,"<<$op>>","clipboard$op");
+ }
+ return $class;
+}
+
+sub clipboardSet
+{
+ my $w = shift;
+ $w->clipboardClear;
+ $w->clipboardAppend(@_);
+}
+
+sub clipboardCopy
+{
+ my $w = shift;
+ my $val = $w->getSelected;
+ if (defined $val)
+ {
+ $w->clipboardSet('--',$val);
+ }
+ return $val;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ my $val = $w->clipboardCopy;
+ if (defined $val)
+ {
+ $w->deleteSelected;
+ }
+ return $val;
+}
+
+sub clipboardGet
+{
+ my $w = shift;
+ $w->SelectionGet('-selection','CLIPBOARD',@_);
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ local $@;
+ catch
+ {
+## Different from Tcl/Tk version:
+# if ($w->windowingsystem eq 'x11')
+# {
+# catch
+# {
+# $w->deleteSelected;
+# };
+# }
+ $w->insert("insert", $w->clipboardGet);
+ $w->SeeInsert if $w->can('SeeInsert');
+ };
+}
+
+sub clipboardOperations
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ while (@_)
+ {
+ my $op = shift;
+ $mw->Tk::bind(@class,"<<$op>>","clipboard$op");
+ }
+}
+
+# These methods work for Entry and Text
+# and can be overridden where they don't work
+
+sub deleteSelected
+{
+ my $w = shift;
+ catch { $w->delete('sel.first','sel.last') };
+}
+
+
+1;
+__END__
+
+sub getSelected
+{
+ my $w = shift;
+ my $val = Tk::catch { $w->get('sel.first','sel.last') };
+ return $val;
+}
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm b/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm
new file mode 100644
index 00000000000..2e821e826ae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm
@@ -0,0 +1,954 @@
+package Tk::CmdLine; # -*-Perl-*-
+
+#/----------------------------------------------------------------------------//
+#/ Module: Tk/CmdLine.pm
+#/
+#/ Purpose:
+#/
+#/ Process standard X11 command line options and set initial resources.
+#/
+#/ Author: ???? Date: ????
+#/
+#/ History: SEE POD
+#/----------------------------------------------------------------------------//
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $
+
+use 5.004;
+
+use strict;
+
+use Config;
+
+my $OBJECT = undef; # define the current object
+
+#/----------------------------------------------------------------------------//
+#/ Constructor
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub new # Tk::CmdLine::new()
+{
+ my $this = shift(@_);
+ my $class = ref($this) || $this;
+
+ my $name = 'pTk';
+ $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e'));
+
+ my $self = {
+ name => $name,
+ config => { -name => $name },
+ options => {},
+ methods => {},
+ command => [],
+ synchronous => 0,
+ iconic => 0,
+ motif => ($Tk::strictMotif || 0),
+ resources => {} };
+
+ return bless($self, $class);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Process the arguments in a given array or in @ARGV.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub Argument_ # Tk::CmdLine::Argument_($flag) # private method
+{
+ my $self = shift(@_);
+ my $flag = shift(@_);
+ unless ($self->{offset} < @{$self->{argv}})
+ {
+ die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n";
+ }
+ return splice(@{$self->{argv}}, $self->{offset}, 1);
+}
+
+sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{config}->{"-$name"} = $val;
+}
+
+sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ push(@{$self->{command}}, $flag);
+ $self->{$name} = 1;
+}
+
+sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{"*$name"} = $val;
+}
+
+sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{methods}->{$name} = $val;
+}
+
+sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/)
+ {
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{$1} = $2;
+ }
+}
+
+my %Method = (
+ background => 'Option_',
+ bg => 'background', # alias
+ class => 'Config_',
+ display => 'screen', # alias
+ fg => 'foreground', # alias
+ fn => 'font', # alias
+ font => 'Option_',
+ foreground => 'Option_',
+ geometry => 'Method_',
+ iconic => 'Flag_',
+ iconposition => 'Method_',
+ motif => 'Flag_',
+ name => 'Config_',
+ screen => 'Config_',
+ synchronous => 'Flag_',
+ title => 'Config_',
+ xrm => 'Resource_'
+);
+
+sub SetArguments # Tk::CmdLine::SetArguments([@argument])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ $self->{argv} = (@_ ? [ @_ ] : \@ARGV);
+ $self->{offset} = 0; # its existence will denote that this method has been called
+
+ my @option = ();
+
+ while ($self->{offset} < @{$self->{argv}})
+ {
+ last if ($self->{argv}->[$self->{offset}] eq '--');
+ unless (
+ (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) ||
+ (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2))))
+ {
+ ++$self->{offset};
+ next;
+ }
+
+ next if (!exists($Method{$option[0]}) && ++$self->{offset});
+
+ $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}});
+
+ my $method = $Method{$option[0]};
+
+ if (@option > 1) # replace --<option>=<value> with <value>
+ {
+ $self->{argv}->[$self->{offset}] = $option[1];
+ }
+ else # remove the argument
+ {
+ splice(@{$self->{argv}}, $self->{offset}, 1);
+ }
+
+ $self->$method(('-' . $option[0]), $option[0]);
+ }
+
+ $self->{config}->{-class} ||= ucfirst($self->{config}->{-name});
+
+ delete($self->{argv}); # no longer needed
+
+ return $self;
+}
+
+use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy
+
+#/----------------------------------------------------------------------------//
+#/ Get a list of the arguments that have been processed by SetArguments().
+#/ Returns an array.
+#/----------------------------------------------------------------------------//
+
+sub GetArguments # Tk::CmdLine::GetArguments()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return @{$self->{command}};
+}
+
+#/----------------------------------------------------------------------------//
+#/ Get the value of a configuration option (default: -class).
+#/ Returns the option value.
+#/----------------------------------------------------------------------------//
+
+sub cget # Tk::CmdLine::cget([$option])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ my $option = shift(@_) || '-class';
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef);
+}
+
+#/----------------------------------------------------------------------------//
+
+sub CreateArgs # Tk::CmdLine::CreateArgs()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return $self->{config};
+}
+
+#/----------------------------------------------------------------------------//
+
+sub Tk::MainWindow::apply_command_line
+{
+ my $mw = shift(@_);
+
+ my $self = ($OBJECT ||= __PACKAGE__->new());
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ foreach my $priority (keys(%{$self->{resources}}))
+ {
+ foreach my $resource (@{$self->{resources}->{$priority}})
+ {
+ $mw->optionAdd(@{$resource}, $priority);
+ }
+ }
+
+ foreach my $key (keys(%{$self->{options}}))
+ {
+ $mw->optionAdd($key => $self->{options}->{$key}, 'interactive');
+ }
+
+ foreach my $key (keys(%{$self->{methods}}))
+ {
+ $mw->$key($self->{methods}->{$key});
+ }
+
+ if ($self->{methods}->{geometry})
+ {
+ if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/)
+ {
+ $mw->positionfrom('user');
+ }
+ if ($self->{methods}->{geometry} =~ /\d+x\d+/)
+ {
+ $mw->sizefrom('user');
+ }
+ delete $self->{methods}->{geometry}; # XXX needed?
+ }
+
+ $mw->Synchronize() if $self->{synchronous};
+
+ if ($self->{iconic})
+ {
+ $mw->iconify();
+ $self->{iconic} = 0;
+ }
+
+ $Tk::strictMotif = ($self->{motif} || 0);
+
+ # Both these are needed to reliably save state
+ # but 'hostname' is tricky to do portably.
+ # $mw->client(hostname());
+ $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]);
+ $mw->command([ $self->{name}, @{$self->{command}} ]);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Set the initial resources.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+ return $self unless @_;
+
+ my $data = shift(@_);
+ my $priority = shift(@_) || 'userDefault';
+
+ $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority});
+
+ foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data)
+ {
+ if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format
+ {
+ push(@{$self->{resources}->{$priority}}, [ @{$resource} ])
+ if (@{$resource} == 2);
+ }
+ else # resources in resource file format
+ {
+ push(@{$self->{resources}->{$priority}}, [ $1, $2 ])
+ if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/);
+ }
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with
+#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault').
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub LoadResources # Tk::CmdLine::LoadResources([%options])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ my %options = @_;
+
+ my @file = ();
+ my $echo = (exists($options{-echo})
+ ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef);
+
+ unless (%options && (exists($options{-file}) || exists($options{-symbol})))
+ {
+ @file = (
+ { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' },
+ { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } );
+ }
+ else
+ {
+ @file = { %options };
+ }
+
+ my $delimiter = (($^O eq 'MSWin32') ? ';' : ':');
+
+ foreach my $file (@file)
+ {
+ my $fileSpec = $file->{-spec} = undef;
+ if (exists($file->{-symbol}))
+ {
+ my $xpath = undef;
+ if ($file->{-symbol} eq 'XUSERFILESEARCHPATH')
+ {
+ $file->{-priority} ||= 'userDefault';
+ foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME))
+ {
+ last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol}));
+ }
+ next unless defined($xpath);
+ }
+ else
+ {
+ $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH')
+ ? 'startupFile' : 'userDefault');
+ next unless (
+ exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}}));
+ }
+
+ unless (exists($self->{translation}))
+ {
+ $self->{translation} = {
+ '%l' => '', # ignored
+ '%C' => '', # ignored
+ '%S' => '', # ignored
+ '%L' => ($ENV{LANG} || 'C'), # language
+ '%T' => 'app-defaults', # type
+ '%N' => $self->{config}->{-class} # filename
+ };
+ }
+
+ my @postfix = map({ $_ . '/' . $self->{config}->{-class} }
+ ('/' . $self->{translation}->{'%L'}), '');
+
+ ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath))
+ {
+ if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern
+ {
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec, "\n";
+ }
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ last;
+ }
+ else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS>
+ {
+ foreach my $postfix (@postfix)
+ {
+ my $fileSpec2 = $fileSpec . $postfix;
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec2, "\n";
+ }
+ next unless ((-f $fileSpec2) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec2;
+ last ITEM;
+ }
+ }
+ }
+ }
+ elsif (exists($file->{-file}) && ($fileSpec = $file->{-file}))
+ {
+ print $echo 'Checking ', $fileSpec, "\n" if defined($echo);
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ }
+ }
+
+ foreach my $file (@file)
+ {
+ next unless defined($file->{-spec});
+ local *SPEC;
+ next unless open(SPEC,$file->{-spec});
+ print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo);
+
+ my $resource = undef;
+ my @resource = ();
+ my $continuation = 0;
+
+ while (defined(my $line = <SPEC>))
+ {
+ chomp($line);
+ next if ($line =~ /^\s*$/); # skip blank lines
+ next if ($line =~ /^\s*!/); # skip comments
+ $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash
+ unless (defined($resource)) # it is the first line
+ {
+ $resource = $line;
+ }
+ else # it is a continuation line
+ {
+ $line =~ s/^\s*//; # remove leading whitespace
+ $resource .= $line;
+ }
+ next if $continuation;
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ $resource = undef;
+ }
+
+ close(SPEC);
+
+ if (defined($resource)) # special case - EOF after line with trailing backslash
+ {
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ }
+
+ $self->SetResources(\@resource, $file->{-priority}) if @resource;
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+
+1;
+
+__END__
+
+=cut
+
+=head1 NAME
+
+Tk::CmdLine - Process standard X11 command line options and set initial resources
+
+=for pm Tk/CmdLine.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ Tk::CmdLine::SetArguments([@argument]);
+
+ my $value = Tk::CmdLine::cget([$option]);
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]);
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+=head1 DESCRIPTION
+
+Process standard X11 command line options and set initial resources.
+
+The X11R5 man page for X11 says: "Most X programs attempt to use the same names
+for command line options and arguments. All applications written with the
+X Toolkit Intrinsics automatically accept the following options: ...".
+This module processes these command line options for perl/Tk applications
+using the C<SetArguments>() function.
+
+This module can optionally be used to load initial resources explicitly via
+function C<SetResources>(), or from specified files (default: the standard X11
+application-specific resource files) via function C<LoadResources>().
+
+=head2 Command Line Options
+
+=over 4
+
+=item B<-background> I<Color> | B<-bg> I<Color>
+
+Specifies the color to be used for the window background.
+
+=item B<-class> I<Class>
+
+Specifies the class under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-display> I<Display> | B<-screen> I<Display>
+
+Specifies the name of the X server to be used.
+
+=item B<-font> I<Font> | B<-fn> I<Font>
+
+Specifies the font to be used for displaying text.
+
+=item B<-foreground> I<Color> | B<-fg> I<Color>
+
+Specifies the color to be used for text or graphics.
+
+=item B<-geometry> I<Geometry>
+
+Specifies the initial size and location of the I<first>
+L<MainWindow|Tk::MainWindow>.
+
+=item B<-iconic>
+
+Indicates that the user would prefer that the application's windows initially
+not be visible as if the windows had been immediately iconified by the user.
+Window managers may choose not to honor the application's request.
+
+=item B<-motif>
+
+Specifies that the application should adhere as closely as possible to Motif
+look-and-feel standards. For example, active elements such as buttons and
+scrollbar sliders will not change color when the pointer passes over them.
+
+=item B<-name> I<Name>
+
+Specifies the name under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-synchronous>
+
+Indicates that requests to the X server should be sent synchronously, instead of
+asynchronously. Since Xlib normally buffers requests to the server, errors do
+do not necessarily get reported immediately after they occur. This option turns
+off the buffering so that the application can be debugged. It should never
+be used with a working program.
+
+=item B<-title> I<TitleString>
+
+This option specifies the title to be used for this window. This information is
+sometimes used by a window manager to provide some sort of header identifying
+the window.
+
+=item B<-xrm> I<ResourceString>
+
+Specifies a resource pattern and value to override any defaults. It is also
+very useful for setting resources that do not have explicit command line
+arguments.
+
+The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>,
+that is (the first) ':' is used to determine which part is pattern and which
+part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered
+into the options database with B<optionAdd> (for each
+L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority.
+
+=back
+
+=head2 Initial Resources
+
+There are several mechanism for initializing the resource database to be used
+by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file,
+a system application defaults file (e.g.
+/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>),
+or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>).
+The Tk::CmdLine functionality for setting initial resources concerns itself
+with the latter two.
+
+Resource files contain data lines of the form
+E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+They may also contain blank lines and comment lines (denoted
+by a ! character as the first non-blank character). Refer to L<option|Tk::option>
+for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+
+=over 4
+
+=item System Application Defaults Files
+
+System application defaults files may be specified via environment variable
+$C<XFILESEARCHPATH> which, if set, contains a list of file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+
+=item User Application Defaults Files
+
+User application defaults files may be specified via environment variables
+$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument])
+
+Extract the X11 options contained in a specified array (@ARGV by default).
+
+ Tk::CmdLine::SetArguments([@argument])
+
+The X11 options may be specified using a single dash I<-> as per the X11
+convention, or using two dashes I<--> as per the POSIX standard (e.g.
+B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>).
+The options may be interspersed with other options or arguments.
+A I<--> by itself terminates option processing.
+
+By default, command line options are extracted from @ARGV the first time
+a MainWindow is created. The Tk::MainWindow constructor indirectly invokes
+C<SetArguments>() to do this.
+
+=item B<GetArguments> - Tk::CmdLine::GetArguments()
+
+Get a list of the X11 options that have been processed by C<SetArguments>().
+(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+=item B<cget> - Tk::CmdLine::cget([$option])
+
+Get the value of a configuration option specified via C<SetArguments>().
+(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+ Tk::CmdLine::cget([$option])
+
+The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>.
+If no option is specified, B<-class> is implied.
+
+A typical use of C<cget>() might be to obtain the application class in order
+to define the name of a resource file to be loaded in via C<LoadResources>().
+
+ my $class = Tk::CmdLine::cget(); # process command line and return class
+
+=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+Set the initial resources.
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+A single resource may be specified using a string of the form
+'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified
+by passing an array reference whose elements are either strings of the above
+form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>,
+E<lt>I<value>E<gt> ]. The optional second argument specifies the priority,
+as defined in L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+Note that C<SetResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=item B<LoadResources> - Tk::CmdLine::LoadResources([%options])
+
+Load initial resources from one or more files.
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable
+that, if set, defines a list of one or more directories and/or file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+$C<XUSERFILESEARCHPATH> is a special case.
+If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead.
+If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead.
+
+An item is identified as a file pattern if it contains one or more /%[A-Za-z]/
+patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All
+others are replaced with the null string. Pattern B<%L> is translated into
+$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is
+translated into the application class name.
+
+Each file pattern, after substitutions are applied, is assumed to define a
+FileSpec to be examined.
+
+When a directory is specified, FileSpecs
+E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt>
+and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order.
+
+[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in.
+The file is silently skipped if if does not exist, or if it is not readable.
+
+[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in
+L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be
+printed to the corresponding FileHandle (default: \*STDOUT) everytime a file
+is examined / loaded.
+
+If no B<-symbol> or B<-file> options are specified, C<LoadResources>()
+processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and
+$C<XUSERFILESEARCHPATH> with priority I<userDefault>.
+(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to
+contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single
+directory. C<LoadResources>() does not check/care whether this is the case.)
+
+For each set of FileSpecs, C<LoadResources>() examines each FileSpec to
+determine if the file exists and is readable. The first file that meets this
+criteria is read in and C<SetResources>() is invoked.
+
+Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=back
+
+=head1 NOTES
+
+This module is an object-oriented module whose methods can be invoked as object
+methods, class methods or regular functions. This is accomplished via an
+internally-maintained object reference which is created as necessary, and which
+always points to the last object used. C<SetArguments>(), C<SetResources>() and
+C<LoadResources>() return the object reference.
+
+=head1 EXAMPLES
+
+=over
+
+=item 1
+
+@ARGV is processed by Tk::CmdLine at MainWindow creation.
+
+ use Tk;
+
+ # <Process @ARGV - ignoring all X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 2
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+An @ARGV of (--geometry=100x100 -opt1 a b c -bg red)
+is equal to (-opt1 a b c) after C<SetArguments>() is invoked.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 3
+
+Just like 2) except that default arguments are loaded first.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(qw(-name test -iconic));
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 4
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 5
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation
+using non-default priorities.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 65, -symbol => 'XFILESEARCHPATH' );
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 75, -symbol => 'XUSERFILESEARCHPATH' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 6
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+Individual resources are also loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ Tk::CmdLine::SetResources( # set a single resource
+ '*Button*background: red',
+ 'widgetDefault' );
+
+ Tk::CmdLine::SetResources( # set multiple resources
+ [ '*Button*background: red', '*Button*foreground: blue' ],
+ 'widgetDefault' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<HOME> (optional)
+
+Home directory which may contain user application defaults files as
+$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>.
+
+=item B<LANG> (optional)
+
+The current language (default: I<C>).
+
+=item B<XFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining system application defaults files.
+
+=item B<XUSERFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining user application defaults files.
+
+=item B<XAPPLRESDIR> (optional)
+
+Directory containing user application defaults files as
+$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or
+$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>.
+
+=back
+
+=head1 SEE ALSO
+
+L<MainWindow|Tk::MainWindow>
+L<option|Tk::option>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Rewritten as an object-oriented module.
+
+Allow one to process command line options in a specified array (@ARGV by default).
+Eliminate restrictions on the format and location of the options within the array
+(previously the X11 options could not be specified in POSIX format and had to be
+at the beginning of the array).
+
+Added the C<SetResources>() and C<LoadResources>() functions to allow the definition
+of resources prior to MainWindow creation.
+
+=item *
+
+2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Added the C<GetArguments>() method which returns the list of arguments that
+have been processed by C<SetArguments>().
+
+Modified C<LoadResources>() to split the symbols using the OS-dependent
+path delimiter defined in the B<Config> module.
+
+Modified C<LoadResources>() to eliminate a warning message when processing
+patterns B<%l>, B<%C>, B<%S>.
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm b/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm
new file mode 100644
index 00000000000..ef3474cd869
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ColorEdit.xpm
@@ -0,0 +1,58 @@
+/* XPM */
+static char * ColorEditor_xpm[] = {
+"48 48 6 1",
+" c #0000FFFF0000",
+". c #FFFFFFFF0000",
+"X c #FFFF00000000",
+"o c #000000000000",
+"O c #0000FFFFFFFF",
+"+ c #00000000FFFF",
+" . . ......X..XXXXXXXXXXXXXXXX",
+" . .X.X. X...XX.XXXXXXXXXXX",
+" . . . ... ...XXXXXXXXXXXXXX",
+" . . .. .....XX.XXXXXXXXXXXX",
+" . .X.X...XXX..XXXXXXXXXXXX",
+" .. . ....X...X.XXXXXXXXX",
+" .. ..X.. . ..X..XXXXXXXX",
+" .... ..X.X..X.XXXXXXX",
+" ... .X. X...X...XX.XXX",
+" . .. ... XX...XXXX..XXXX",
+" ooo o ooo. . .. .X...X..X.XXXXX",
+" oo oo oo. . . . .......X.X.XX",
+" oo o oo . . .. ........XX.XXXX",
+" oo ooo oo ooo Xooo.oo..... X XX.X",
+" oo o oo oo o oo ooo o.. . X...X X",
+" oo oo oo oo oo oo .oo . X.X.....XX ",
+"O oo o oo oo oo oo oo oo. ... X..... .",
+"O O oo oo oo o oo ooo o. oo . ... .X..X",
+"O OOOooooO ooo ooo ooo oo ... ....... X ",
+" O OOO . . .. ... ..",
+"OOO OOOO OO O . .... . . .. .",
+" + O O O O .. .. . .",
+" O OOO OO . .. .... ",
+"OOOOO O OO . .. . ... ",
+"+OOOO OOOO OO O ... .. ..",
+" O+OO OO O . ",
+"OOOOOOOOoooooooOOOO ooo oo .... ",
+"OO++ OOO ooO OoOO oo oo oo .. ",
+"+OOOOOOOOooOOOo O O oo oo .",
+"++OOO +oo+oOO O oo oo ooo ooooo ooo ooo oo. ",
+"+OO O OOoooooO O o ooo oo oo o oo ooo o ",
+"++++ O OooOOoO Ooo Ooo oo oo oo oo oo ",
+"+++OOOO ooOOOoOOooOOooO oo oo oo oo oo ",
+"++++++ Ooo OOoOOooOooo ooo ooo o oo o oo ",
+"+++O+++oooooooOOOooOoooOooo ooo Oooo oo ",
+"++++++++O++OOOO O OOOOOOO ",
+"++O++++O+O+OOOOOOO O O OOOOOO O ",
+"+++O+++OOO+OO OOOO O OO O O O ",
+"++++++++O++O OO OO OO OOO OO O O ",
+"+++++++++++++ OOOOOO OOOO OO OO ",
+"+++++++++++++O+ +O OOOO OOO OOO OOO ",
+"++++++++++++++ OOOOO O OOOOOOOOOO ",
+"+++++++++++++ ++ OO +O OOOOO O O O ",
+"+++++++++++++++O+++O+O+O OOOOOOOOOO O ",
+"+++++++++++++O++++O++ O OOO O OOO OO ",
+"++++++++++++++++O+++O+O+OOOO OOOO O OO ",
+"+++++++++++++++++++O+++ +++O OOOOOO OO O ",
+"++++++++++++++++++++++ +++ O OOOOOOOOO "};
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm
new file mode 100644
index 00000000000..e84b0077410
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ColorEditor.pm
@@ -0,0 +1,761 @@
+package Tk::ColorSelect;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev);
+
+require Tk::Frame;
+
+use base qw(Tk::Frame);
+Construct Tk::Widget 'ColorSelect';
+
+sub Populate
+{
+ my ($middle,$args) = @_;
+ my($i, @a);
+ require Tk::Config;
+ my(@xlibpath) = map { s/^-L//; "$_/X11/rgb.txt" }
+ split /\s+/, $Tk::Config::xlib;
+ foreach $i (@xlibpath,
+ '/usr/local/lib/X11/rgb.txt', '/usr/lib/X11/rgb.txt',
+ '/usr/X11R6/lib/X11/rgb.txt',
+ '/usr/local/X11R5/lib/X11/rgb.txt', '/X11/R5/lib/X11/rgb.txt',
+ '/X11/R4/lib/rgb/rgb.txt', '/usr/openwin/lib/X11/rgb.txt') {
+ local *FOO;
+ next if ! open FOO, $i;
+ my $middle_left = $middle->Frame;
+ $middle_left->pack(
+ -side => 'left',
+ -padx => '0.25c',
+ -pady => '0.25c',
+ );
+ my $names = $middle->Listbox(
+ -width => 20,
+ -height => 12,
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -exportselection => 0,
+ );
+
+ $names->bind('<Double-1>' => [$middle,'color',Ev(['getSelected'])]);
+
+ my $scroll = $middle->Scrollbar(
+ -orient => 'vertical',
+ -command => ['yview', $names],
+ -relief => 'sunken',
+ -borderwidth => 2,
+ );
+ $names->configure(-yscrollcommand => ['set',$scroll]);
+ $names->pack(-in => $middle_left, -side => 'left');
+ $scroll->pack(-in => $middle_left, -side => 'right', -fill => 'y');
+
+ while(<FOO>) {
+ chomp;
+ next if /^!/;
+ my @a = split;
+ my $color = join(' ', @a[3 .. $#a]);
+ my $hex;
+ eval { $hex = $middle->Hex($color); };
+ if ($@) {
+ #print STDERR "unknown color: '$color'\n";
+ if ($@ =~ /unknown color name "/) {
+ next;
+ } else {
+ chomp $@;
+ die $@;
+ }
+ }
+ if (!exists($Tk::ColorEditor::names{$hex}) ||
+ length($Tk::ColorEditor::names{$hex}) > length($color)) {
+ $Tk::ColorEditor::names{$hex} = $color;
+ $names->insert('end', $color);
+ }
+ }
+ close FOO;
+ last;
+ }
+
+ # Create the three scales for editing the color, and the entry for typing
+ # in a color value.
+
+ my $middle_middle = $middle->Frame;
+ $middle_middle->pack(-side => 'left', -expand => 1, -fill => 'y');
+ my $mcm1 = $middle_middle->Optionmenu(-variable => \$middle->{'color_space'},
+ -command => [ $middle, 'color_space'],
+ -relief => 'raised',
+ -options => [ ['HSB color space' => 'hsb'],
+ ['RGB color space' => 'rgb'],
+ ['CMY color space' => 'cmy']]);
+ $mcm1->pack(-side => 'top', -fill => 'x');
+
+ my(@middle_middle, @label, @scale);
+ $middle_middle[0] = $middle_middle->Frame;
+ $middle_middle[1] = $middle_middle->Frame;
+ $middle_middle[2] = $middle_middle->Frame;
+ $middle_middle[3] = $middle_middle->Frame;
+ $middle_middle[0]->pack(-side => 'top', -expand => 1);
+ $middle_middle[1]->pack(-side => 'top', -expand => 1);
+ $middle_middle[2]->pack(-side => 'top', -expand => 1);
+ $middle_middle[3]->pack(-side => 'top', -expand => 1, -fill => 'x');
+ $middle->{'Labels'} = ['zero','one','two'];
+ foreach $i (0..2) {
+ $label[$i] = $middle->Label(-textvariable => \$middle->{'Labels'}[$i]);
+ $scale[$i] = $middle->Scale(
+ -from => 0,
+ -to => 1000,
+ '-length' => '6c',
+ -orient => 'horizontal',
+ -command => [\&scale_changed, $middle],
+ );
+ $scale[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ $label[$i]->pack(
+ -in => $middle_middle[$i],
+ -side => 'top',
+ -anchor => 'w',
+ );
+ }
+ my $nameLabel = $middle->Label(-text => 'Name:');
+ $middle->{'Entry'} = '';
+ my $name = $middle->Entry(
+ -relief => 'sunken',
+ -borderwidth => 2,
+ -textvariable => \$middle->{'Entry'},
+ -width => 10,
+# For some reason giving this font causes problems at end of t/create.t
+# -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $nameLabel->pack(-in => $middle_middle[3], -side => 'left');
+ $name->pack(
+ -in => $middle_middle[3],
+ -side => 'right',
+ -expand => 1,
+ -fill => 'x',
+ );
+ $name->bind('<Return>' => [ $middle, 'color', Ev(['get'])]);
+
+ # Create the color display swatch on the right side of the window.
+
+ my $middle_right = $middle->Frame;
+ $middle_right->pack(
+ -side => 'left',
+ -pady => '.25c',
+ -padx => '.25c',
+ -anchor => 's',
+ );
+ my $swatch = $middle->Canvas(
+ -width => '2.5c',
+ -height => '5c',
+ );
+ my $swatch_item = $swatch->create('oval', '.5c', '.3c', '2.26c', '4.76c');
+
+ my $value = $middle->Label(
+ -textvariable => \$middle->{'color'},
+ -width => 13,
+ -font => '-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*'
+ );
+
+ $swatch->pack(
+ -in => $middle_right,
+ -side => 'top',
+ -expand => 1,
+ -fill => 'both',
+ );
+ $value->pack(-in => $middle_right, -side => 'bottom', -pady => '.25c');
+
+ $middle->ConfigSpecs(
+ '-color_space' => ['METHOD', undef, undef, 'hsb'],
+ '-initialcolor' => '-color',
+ '-color' => ['METHOD', 'background', 'Background',
+ $middle->cget('-background')]
+ );
+
+ $middle->{'swatch'} = $swatch;
+ $middle->{'swatch_item'} = $swatch_item;
+ $middle->{'scale'} = [@scale];
+ $middle->{'red'} = 0;
+ $middle->{'blue'} = 0;
+ $middle->{'green'} = 0;
+
+}
+
+sub Hex
+{
+ my $w = shift;
+ my @rgb = (@_ == 3) ? @_ : $w->rgb(@_);
+ sprintf('#%04x%04x%04x',@rgb)
+}
+
+sub color_space {
+
+ my($objref, $space) = @_;
+
+ if (@_ > 1)
+ {
+ my %Labels = ( 'rgb' => [qw(Red Green Blue)],
+ 'cmy' => [qw(Cyan Magenta Yellow)],
+ 'hsb' => [qw(Hue Saturation Brightness)] );
+
+ # The procedure below is invoked when a new color space is selected. It
+ # changes the labels on the scales and re-loads the scales with the
+ # appropriate values for the current color in the new color space
+
+ $space = 'hsb' unless (exists $Labels{$space});
+ my $i;
+ for $i (0..2)
+ {
+ $objref->{'Labels'}[$i] = $Labels{$space}->[$i];
+ }
+ $objref->{'color_space'} = $space;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ }
+ return $objref->{'color_space'};
+} # color_space
+
+sub hsvToRgb {
+
+ # The procedure below converts an HSB value to RGB. It takes hue,
+ # saturation, and value components (floating-point, 0-1.0) as arguments,
+ # and returns a list containing RGB components (integers, 0-65535) as
+ # result. The code here is a copy of the code on page 616 of
+ # "Fundamentals of Interactive Computer Graphics" by Foley and Van Dam.
+
+ my($hue, $sat, $value) = @_;
+ my($v, $i, $f, $p, $q, $t);
+
+ $v = int(65535 * $value);
+ return ($v, $v, $v) if $sat == 0;
+ $hue *= 6;
+ $hue = 0 if $hue >= 6;
+ $i = int($hue);
+ $f = $hue - $i;
+ $p = int(65535 * $value * (1 - $sat));
+ $q = int(65535 * $value * (1 - ($sat * $f)));
+ $t = int(65535 * $value * (1 - ($sat * (1 - $f))));
+ return ($v, $t, $p) if $i == 0;
+ return ($q, $v, $p) if $i == 1;
+ return ($p, $v, $t) if $i == 2;
+ return ($p, $q, $v) if $i == 3;
+ return ($t, $p, $v) if $i == 4;
+ return ($v, $p, $q) if $i == 5;
+
+} # end hsvToRgb
+
+sub color
+{
+ my ($objref,$name) = @_;
+ if (@_ > 1 && defined($name) && length($name))
+ {
+ if ($name eq 'cancel') {
+ $objref->{color} = undef;
+ return;
+ }
+ my ($format, $shift);
+ my ($red, $green, $blue);
+
+ if ($name !~ /^#/)
+ {
+ ($red, $green, $blue) = $objref->{'swatch'}->rgb($name);
+ }
+ else
+ {
+ my $len = length $name;
+ if($len == 4) { $format = '#(.)(.)(.)'; $shift = 12; }
+ elsif($len == 7) { $format = '#(..)(..)(..)'; $shift = 8; }
+ elsif($len == 10) { $format = '#(...)(...)(...)'; $shift = 4; }
+ elsif($len == 13) { $format = '#(....)(....)(....)'; $shift = 0; }
+ else {
+ $objref->BackTrace(
+ "ColorEditor error: syntax error in color name \"$name\"");
+ return;
+ }
+ ($red,$green,$blue) = $name =~ /$format/;
+ # Looks like a call for 'pack' or similar rather than eval
+ eval "\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;";
+ $red = $red << $shift;
+ $green = $green << $shift;
+ $blue = $blue << $shift;
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ my $hex = sprintf('#%04x%04x%04x', $red, $green, $blue);
+ $objref->{'color'} = $hex;
+ $objref->{'Entry'} = $name;
+ $objref->afterIdle(['set_scales',$objref]) unless ($objref->{'pending'}++);
+ $objref->{'swatch'}->itemconfigure($objref->{'swatch_item'},
+ -fill => $objref->{'color'});
+ }
+ return $objref->{'color'};
+}
+
+sub rgbToHsv {
+
+ # The procedure below converts an RGB value to HSB. It takes red, green,
+ # and blue components (0-65535) as arguments, and returns a list
+ # containing HSB components (floating-point, 0-1) as result. The code
+ # here is a copy of the code on page 615 of "Fundamentals of Interactive
+ # Computer Graphics" by Foley and Van Dam.
+
+ my($red, $green, $blue) = @_;
+ my($max, $min, $sat, $range, $hue, $rc, $gc, $bc);
+
+ $max = ($red > $green) ? (($blue > $red) ? $blue : $red) :
+ (($blue > $green) ? $blue : $green);
+ $min = ($red < $green) ? (($blue < $red) ? $blue : $red) :
+ (($blue < $green) ? $blue : $green);
+ $range = $max - $min;
+ if ($max == 0) {
+ $sat = 0;
+ } else {
+ $sat = $range / $max;
+ }
+ if ($sat == 0) {
+ $hue = 0;
+ } else {
+ $rc = ($max - $red) / $range;
+ $gc = ($max - $green) / $range;
+ $bc = ($max - $blue) / $range;
+ $hue = ($max == $red)?(0.166667*($bc - $gc)):
+ (($max == $green)?(0.166667*(2 + $rc - $bc)):
+ (0.166667*(4 + $gc - $rc)));
+ }
+ $hue += 1 if $hue < 0;
+ return ($hue, $sat, $max/65535);
+
+} # end rgbToHsv
+
+sub scale_changed {
+
+ # The procedure below is invoked when one of the scales is adjusted. It
+ # propagates color information from the current scale readings to
+ # everywhere else that it is used.
+
+ my($objref) = @_;
+
+ return if $objref->{'updating'};
+ my ($red, $green, $blue);
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $red = int($objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int($objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int($objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $red = int(65535 - $objref->{'scale'}->[0]->get * 65.535 + 0.5);
+ $green = int(65535 - $objref->{'scale'}->[1]->get * 65.535 + 0.5);
+ $blue = int(65535 - $objref->{'scale'}->[2]->get * 65.535 + 0.5);
+ } else {
+ ($red, $green, $blue) = hsvToRgb($objref->{'scale'}->[0]->get/1000.0,
+ $objref->{'scale'}->[1]->get/1000.0,
+ $objref->{'scale'}->[2]->get/1000.0);
+ }
+ $objref->{'red'} = $red;
+ $objref->{'blue'} = $blue;
+ $objref->{'green'} = $green;
+ $objref->color(sprintf('#%04x%04x%04x', $red, $green, $blue));
+ $objref->idletasks;
+
+} # end scale_changed
+
+sub set_scales {
+
+ my($objref) = @_;
+ $objref->{'pending'} = 0;
+ $objref->{'updating'} = 1;
+
+ # The procedure below is invoked to update the scales from the current red,
+ # green, and blue intensities. It's invoked after a change in the color
+ # space and after a named color value has been loaded.
+
+ my($red, $blue, $green) = ($objref->{'red'}, $objref->{'blue'},
+ $objref->{'green'});
+
+ if($objref->{'color_space'} eq 'rgb') {
+ $objref->{'scale'}->[0]->set(int($red / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int($green / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int($blue / 65.535 + 0.5));
+ } elsif($objref->{'color_space'} eq 'cmy') {
+ $objref->{'scale'}->[0]->set(int((65535 - $red) / 65.535 + 0.5));
+ $objref->{'scale'}->[1]->set(int((65535 - $green) / 65.535 + 0.5));
+ $objref->{'scale'}->[2]->set(int((65535 - $blue) / 65.535 + 0.5));
+ } else {
+ my ($s1, $s2, $s3) = rgbToHsv($red, $green, $blue);
+ $objref->{'scale'}->[0]->set(int($s1 * 1000.0 + 0.5));
+ $objref->{'scale'}->[1]->set(int($s2 * 1000.0 + 0.5));
+ $objref->{'scale'}->[2]->set(int($s3 * 1000.0 + 0.5));
+ }
+ $objref->{'updating'} = 0;
+
+} # end set_scales
+
+package Tk::ColorDialog;
+require Tk::Toplevel;
+use base qw(Tk::Toplevel);
+
+Construct Tk::Widget 'ColorDialog';
+
+sub Accept
+{
+ my $cw = shift;
+ $cw->withdraw;
+ $cw->{'done'} = 1;
+}
+
+sub Cancel
+{
+ my $cw = shift;
+# $cw->configure(-color => undef);
+ $cw->configure(-color => 'cancel');
+ $cw->Accept;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->SUPER::Populate($args);
+ $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ my $sel = $cw->ColorSelect;
+ my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
+ my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
+ Tk::grid($sel);
+ Tk::grid($accept,$cancel);
+ $cw->ConfigSpecs(DEFAULT => [$sel]);
+}
+
+sub Show
+{
+ my $cw = shift;
+ $cw->configure(@_) if @_;
+ $cw->Popup();
+ $cw->waitVariable(\$cw->{'done'});
+ $cw->withdraw;
+ return $cw->cget('-color');
+}
+
+package Tk::ColorEditor;
+
+use vars qw($VERSION $SET_PALETTE);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(lsearch Ev);
+use Tk::Toplevel;
+use base qw(Tk::Toplevel);
+use Tk::widgets qw(Pixmap);
+Construct Tk::Widget 'ColorEditor';
+
+%Tk::ColorEditor::names = ();
+
+
+use Tk::Dialog;
+use Tk::Pretty;
+
+BEGIN { $SET_PALETTE = 'Set Palette' };
+
+use subs qw(color_space hsvToRgb rgbToHsv);
+
+# ColorEditor public methods.
+
+sub add_menu_item
+{
+ my $objref = shift;
+ my $value;
+ foreach $value (@_)
+ {
+ if ($value eq 'SEP')
+ {
+ $objref->{'mcm2'}->separator;
+ }
+ else
+ {
+ $objref->{'mcm2'}->command( -label => $value,
+ -command => [ 'configure', $objref, '-highlight' => $value ] );
+ push @{$objref->{'highlight_list'}}, $value;
+ }
+ }
+}
+
+sub set_title
+{
+ my ($w) = @_;
+ my $t = $w->{Configure}{'-title'} || '' ;
+ my $h = $w->{Configure}{'-highlight'} || '';
+ $w->SUPER::title("$t $h Color Editor");
+}
+
+sub highlight
+{
+ my ($w,$h) = @_;
+ if (@_ > 1)
+ {
+ $w->{'update'}->configure( -text => "Apply $h Color" );
+ my $state = ($h eq 'background') ? 'normal' : 'disabled';
+ $w->{'palette'}->entryconfigure( $SET_PALETTE, -state => $state);
+ $w->{'highlight'} = $h;
+ $w->configure(-color => $w->Palette->{$h});
+ $w->set_title;
+ }
+ return $w->{'highlight'};
+}
+
+sub title
+{
+ my ($w,$val) = @_;
+ $w->set_title if (@_ > 1);
+ return $w->{Configure}{'-title'};
+}
+
+sub delete_menu_item
+{
+ my $objref = shift;
+ my $value;
+ foreach $value (@_)
+ {
+ $objref->{'mcm2'}->delete($value);
+ my $list_ord = $value =~ /\d+/ ? $value : lsearch($objref->{'highlight_list'}, $value);
+ splice(@{$objref->{'highlight_list'}}, $list_ord, 1) if $list_ord != -1;
+ }
+}
+
+sub delete_widgets {
+
+ # Remove widgets from consideration by the color configurator.
+ # $widgets_ref points to widgets previously added via `configure'.
+
+ my($objref, $widgets_ref) = @_;
+
+ my($i, $found, $r1, $r2, @wl) = (0, 0, 0, 0, @{$objref->cget(-widgets)});
+ foreach $r1 (@{$widgets_ref}) {
+ $i = -1;
+ $found = 0;
+ foreach $r2 (@wl) {
+ $i++;
+ next if $r1 != $r2;
+ $found = 1;
+ last;
+ }
+ splice(@wl, $i, 1) if $found;
+ }
+ $objref->configure(-widgets => [@wl]);
+
+} # end delete_widgets
+
+sub ApplyDefault
+{
+ my($objref) = @_;
+ my $cb = $objref->cget('-command');
+ my $h;
+ foreach $h (@{$objref->{'highlight_list'}})
+ {
+ next if $h =~ /TEAR_SEP|SEP/;
+ $cb->Call($h);
+ die unless (defined $cb);
+ }
+}
+
+sub Populate
+{
+
+ # ColorEditor constructor.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ $cw->withdraw;
+
+ my $color_space = 'hsb'; # rgb, cmy, hsb
+ my(@highlight_list) = qw(
+ TEAR_SEP
+ foreground background SEP
+ activeForeground activeBackground SEP
+ highlightColor highlightBackground SEP
+ selectForeground selectBackground SEP
+ disabledForeground insertBackground selectColor troughColor
+ );
+
+ # Create the Usage Dialog;
+
+ my $usage = $cw->Dialog( '-title' => 'ColorEditor Usage',
+ -justify => 'left',
+ -wraplength => '6i',
+ -text => "The Colors menu allows you to:\n\nSelect a color attribute such as \"background\" that you wish to colorize. Click on \"Apply\" to update that single color attribute.\n\nSelect one of three color spaces. All color spaces display a color value as a hexadecimal number under the oval color swatch that can be directly supplied on widget commands.\n\nApply Tk's default color scheme to the application. Useful if you've made a mess of things and want to start over!\n\nChange the application's color palette. Make sure \"background\" is selected as the color attribute, find a pleasing background color to apply to all current and future application widgets, then select \"Set Palette\".",
+ );
+
+ # Create the menu bar at the top of the window for the File, Colors
+ # and Help menubuttons.
+
+ my $m0 = $cw->Frame(-relief => 'raised', -borderwidth => 2);
+ $m0->pack(-side => 'top', -fill => 'x');
+ my $mf = $m0->Menubutton(
+ -text => 'File',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mf->pack(-side => 'left');
+ my $close_command = [sub {shift->withdraw}, $cw];
+ $mf->command(
+ -label => 'Close',
+ -underline => 0,
+ -command => $close_command,
+ -accelerator => 'Ctrl-w',
+ );
+ $cw->bind('<Control-Key-w>' => $close_command);
+ $cw->protocol(WM_DELETE_WINDOW => $close_command);
+
+ my $mc = $m0->Menubutton(
+ -text => 'Colors',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mc->pack(-side => 'left');
+ my $color_attributes = 'Color Attributes';
+ $mc->cascade(-label => $color_attributes, -underline => 6);
+ $mc->separator;
+
+ $mc->command(
+ -label => 'Apply Default Colors',
+ -underline => 6,
+ -command => ['ApplyDefault',$cw]
+ );
+ $mc->separator;
+ $mc->command(
+ -label => $SET_PALETTE,
+ -underline => 0,
+ -command => sub { $cw->setPalette($cw->cget('-color'))}
+ );
+
+ my $m1 = $mc->cget(-menu);
+
+ my $mcm2 = $m1->Menu;
+ $m1->entryconfigure($color_attributes, -menu => $mcm2);
+ my $mh = $m0->Menubutton(
+ -text => 'Help',
+ -underline => 0,
+ -bd => 1,
+ -relief => 'raised',
+ );
+ $mh->pack(-side => 'right');
+ $mh->command(
+ -label => 'Usage',
+ -underline => 0,
+ -command => [sub {shift->Show}, $usage],
+ );
+
+ # Create the Apply button.
+
+ my $bot = $cw->Frame(-relief => 'raised', -bd => 2);
+ $bot->pack(-side => 'bottom', -fill =>'x');
+ my $update = $bot->Button(
+ -command => [
+ sub {
+ my ($objref) = @_;
+ $objref->Callback(-command => ($objref->{'highlight'}, $objref->cget('-color')));
+ $cw->{'done'} = 1;
+ }, $cw,
+ ],
+ );
+ $update->pack(-pady => 1, -padx => '0.25c');
+
+ # Create the listbox that holds all of the color names in rgb.txt, if an
+ # rgb.txt file can be found.
+
+ my $middle = $cw->ColorSelect(-relief => 'raised', -borderwidth => 2);
+ $middle->pack(-side => 'top', -fill => 'both');
+ # Create the status window.
+
+ my $status = $cw->Toplevel;
+ $status->withdraw;
+ $status->geometry('+0+0');
+ my $status_l = $status->Label(-width => 50, -anchor => 'w');
+ $status_l->pack(-side => 'top');
+
+ $cw->{'highlight_list'} = [@highlight_list];
+ $cw->{'mcm2'} = $mcm2;
+
+ foreach (@highlight_list)
+ {
+ next if /^TEAR_SEP$/;
+ $cw->add_menu_item($_);
+ }
+
+ $cw->{'updating'} = 0;
+ $cw->{'pending'} = 0;
+ $cw->{'Status'} = $status;
+ $cw->{'Status_l'} = $status_l;
+ $cw->{'update'} = $update;
+ $cw->{'gwt_depth'} = 0;
+ $cw->{'palette'} = $mc;
+
+ my $pixmap = $cw->Pixmap('-file' => Tk->findINC('ColorEdit.xpm'));
+ $cw->Icon(-image => $pixmap);
+
+ $cw->ConfigSpecs(
+ DEFAULT => [$middle],
+ -widgets => ['PASSIVE', undef, undef,
+ [$cw->parent->Descendants]],
+ -display_status => ['PASSIVE', undef, undef, 0],
+ '-title' => ['METHOD', undef, undef, ''],
+ -command => ['CALLBACK', undef, undef, ['set_colors',$cw]],
+ '-highlight' => ['METHOD', undef, undef, 'background'],
+ -cursor => ['DESCENDANTS', 'cursor', 'Cursor', 'left_ptr'],
+ );
+
+} # end Populate, ColorEditor constructor
+
+sub Show {
+
+ my($objref, @args) = @_;
+
+ Tk::ColorDialog::Show(@_);
+
+} # end show
+
+# ColorEditor default configurator procedure - can be redefined by the
+# application.
+
+sub set_colors {
+
+ # Configure all the widgets in $widgets for attribute $type and color
+ # $color. If $color is undef then reset all colors
+ # to the Tk defaults.
+
+ my($objref, $type, $color) = @_;
+ my $display = $objref->cget('-display_status');
+
+ $objref->{'Status'}->title("Configure $type");
+ $objref->{'Status'}->deiconify if $display;
+ my $widget;
+ my $reset = !defined($color);
+
+ foreach $widget (@{$objref->cget('-widgets')}) {
+ if ($display) {
+ $objref->{'Status_l'}->configure(
+ -text => 'WIDGET: ' . $widget->PathName
+ );
+ $objref->update;
+ }
+ eval {local $SIG{'__DIE__'}; $color = ($widget->configure("-\L${type}"))[3]} if $reset;
+ eval {local $SIG{'__DIE__'}; $widget->configure("-\L${type}" => $color)};
+ }
+
+ $objref->{'Status'}->withdraw if $display;
+
+} # end set_colors
+
+# ColorEditor private methods.
+
+1;
+
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Compound.pm b/Master/tlpkg/tlperl/lib/Tk/Compound.pm
new file mode 100644
index 00000000000..9f1ccd64487
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Compound.pm
@@ -0,0 +1,40 @@
+package Tk::Compound;
+require Tk;
+import Tk qw($XS_VERSION);
+require Tk::Image;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Compound/Compound.pm#4 $
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Compound';
+
+bootstrap Tk::Compound;
+
+sub Tk_image { 'compound' }
+
+Tk::Methods('add');
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ my $leaf = $package->Tk_image;
+ $package->InitClass($widget);
+ my $obj = $widget->image(create => $leaf,@_,-window => $widget);
+ return bless($obj,$package);
+}
+
+BEGIN
+ {
+ foreach my $type (qw(line text image bitmap space))
+ {
+ my $meth = ucfirst($type);
+ no strict qw 'refs';
+ *{$meth} = sub { shift->add($type,@_) };
+ }
+ }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Config.pm b/Master/tlpkg/tlperl/lib/Tk/Config.pm
new file mode 100644
index 00000000000..8346d9ede9a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Config.pm
@@ -0,0 +1,12 @@
+package Tk::Config;
+require Exporter;
+use base qw(Exporter);
+$VERSION = '804.027';
+$inc = '-I$(TKDIR)/pTk/mTk/xlib';
+$define = '';
+$xlib = '';
+$xinc = '';
+$gccopt = ' -Wall -Wno-implicit-int -Wno-comment -Wno-unused -D__USE_FIXED_PROTOTYPES__';
+$win_arch = 'MSWin32';
+@EXPORT = qw($VERSION $inc $define $xlib $xinc $gccopt $win_arch);
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Configure.pm b/Master/tlpkg/tlperl/lib/Tk/Configure.pm
new file mode 100644
index 00000000000..26252ae4958
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Configure.pm
@@ -0,0 +1,69 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
+
+use Carp;
+use Tk::Pretty;
+
+
+# Class that handles cget/configure for options that
+# need translating from public form
+# e.g. $cw->configure(-label => 'fred')
+# into $cw->subwiget('label')->configure(-text => 'fred')
+# Should probably do something clever with regexp's here
+
+
+sub new
+{
+ my ($class,@args) = @_;
+ unshift(@args,'configure','cget') if (@args < 3);
+ return bless \@args,$class;
+}
+
+sub cget
+{
+ croak('Wrong number of args to cget') unless (@_ == 2);
+ my ($alias,$key) = @_;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$get(@args);
+}
+
+sub configure
+{
+ my $alias = shift;
+ shift if (@_);
+ my ($set,$get,$widget,@args) = @$alias;
+ if (wantarray)
+ {
+ my @results;
+ eval { @results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return @results;
+ }
+ else
+ {
+ my $results;
+ eval { $results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return $results;
+ }
+}
+
+*TIESCALAR = \&new;
+*TIEHASH = \&new;
+
+sub FETCH
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ return $widget->$get(@args,@_);
+}
+
+sub STORE
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$set(@args,@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Credits b/Master/tlpkg/tlperl/lib/Tk/Credits
new file mode 100644
index 00000000000..3ea9be43b7d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Credits
@@ -0,0 +1,7 @@
+The two Camel/X 'logo' GIFs were produced by :
+
+Grafix, Sussex, UK, +44-1293-886725
+
+For a very reasonable fee. We have rights to distribute them.
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Derived.pm b/Master/tlpkg/tlperl/lib/Tk/Derived.pm
new file mode 100644
index 00000000000..c31c205d2fb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Derived.pm
@@ -0,0 +1,512 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Derived;
+require Tk::Widget;
+require Tk::Configure;
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+$Tk::Derived::Debug = 0;
+
+my $ENHANCED_CONFIGSPECS = 0; # disable for now
+
+use Tk qw(NORMAL_BG BLACK);
+
+sub Subwidget
+{
+ my $cw = shift;
+ my @result = ();
+ if (exists $cw->{SubWidget})
+ {
+ if (@_)
+ {
+ foreach my $name (@_)
+ {
+ push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
+ }
+ }
+ else
+ {
+ @result = values %{$cw->{SubWidget}};
+ }
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub _makelist
+{
+ my $widget = shift;
+ my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget);
+ return @specs;
+}
+
+sub Subconfigure
+{
+ # This finds the widget or widgets to to which to apply a particular
+ # configure option
+ my ($cw,$opt) = @_;
+ my $config = $cw->ConfigSpecs;
+ my $widget;
+ my @subwidget = ();
+ my @arg = ();
+ if (defined $opt)
+ {
+ $widget = $config->{$opt};
+ unless (defined $widget)
+ {
+ $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
+ }
+ # Handle alias entries
+ if (defined($widget) && !ref($widget))
+ {
+ $opt = $widget;
+ $widget = $config->{$widget};
+ }
+ push(@arg,$opt) unless ($opt eq 'DEFAULT');
+ }
+ $widget = $config->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
+ $widget = $widget->[0];
+ }
+ else
+ {
+ $widget = 'SELF';
+ }
+ foreach $widget (_makelist($widget))
+ {
+ $widget = 'SELF' if (ref($widget) && $widget == $cw);
+ if (ref $widget)
+ {
+ my $ref = ref $widget;
+ if ($ref eq 'ARRAY')
+ {
+ $widget = Tk::Configure->new(@$widget);
+ push(@subwidget,$widget)
+ }
+ elsif ($ref eq 'HASH')
+ {
+ foreach my $key (%$widget)
+ {
+ foreach my $sw (_makelist($widget->{$key}))
+ {
+ push(@subwidget,Tk::Configure->new($sw,$key));
+ }
+ }
+ }
+ else
+ {
+ push(@subwidget,$widget)
+ }
+ }
+ elsif ($widget eq 'ADVERTISED')
+ {
+ push(@subwidget,$cw->Subwidget)
+ }
+ elsif ($widget eq 'DESCENDANTS')
+ {
+ push(@subwidget,$cw->Descendants)
+ }
+ elsif ($widget eq 'CHILDREN')
+ {
+ push(@subwidget,$cw->children)
+ }
+ elsif ($widget eq 'METHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,$method,$cw))
+ }
+ elsif ($widget eq 'SETMETHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'SELF')
+ {
+ push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg))
+ }
+ elsif ($widget eq 'PASSIVE')
+ {
+ push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'CALLBACK')
+ {
+ push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg))
+ }
+ else
+ {
+ push(@subwidget,$cw->Subwidget($widget));
+ }
+ }
+ $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
+ return (wantarray) ? @subwidget : $subwidget[0];
+}
+
+sub _cget
+{
+ my ($cw,$opt) = @_;
+ $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2);
+ return $cw->{Configure}{$opt}
+}
+
+sub _configure
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub _callback
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $val = Tk::Callback->new($val) if defined($val) && ref($val);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub cget
+{my ($cw,$opt) = @_;
+ my @result;
+ local $SIG{'__DIE__'};
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ if (wantarray)
+ {
+ eval { @result = $sw->cget($opt) };
+ }
+ else
+ {
+ eval { $result[0] = $sw->cget($opt) };
+ }
+ last unless $@;
+ }
+ return wantarray ? @result : $result[0];
+}
+
+sub Configured
+{
+ # Called whenever a derived widget is re-configured
+ my ($cw,$args,$changed) = @_;
+ if (@_ > 1)
+ {
+ $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
+ }
+ return exists $cw->{'Configure'};
+}
+
+sub configure
+{
+ # The default composite widget configuration method uses hash stored
+ # in the widget's hash to map configuration options
+ # onto subwidgets.
+ #
+ my @results = ();
+ my $cw = shift;
+ if (@_ <= 1)
+ {
+ # Enquiry cases
+ my $spec = $cw->ConfigSpecs;
+ if (@_)
+ {
+ # Return info on the nominated option
+ my $opt = $_[0];
+ my $info = $spec->{$opt};
+ unless (defined $info)
+ {
+ $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
+ }
+ if (defined $info)
+ {
+ if (ref $info)
+ {
+ # If the default slot is undef then ask subwidgets in turn
+ # for their default value until one accepts it.
+ if ($ENHANCED_CONFIGSPECS && !defined($info->[3]))
+ {local $SIG{'__DIE__'};
+ my @def;
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ eval { @def = $sw->configure($opt) };
+ last unless $@;
+ }
+ $info->[3] = $def[3];
+ $info->[1] = $def[1] unless defined $info->[1];
+ $info->[2] = $def[2] unless defined $info->[2];
+ }
+ push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
+ }
+ else
+ {
+ # Real (core) Tk widgets return db name rather than option name
+ # for aliases so recurse to get that ...
+ my @real = $cw->configure($info);
+ push(@results,$opt,$real[1]);
+ }
+ }
+ else
+ {
+ push(@results,$cw->Subconfigure($opt)->configure($opt));
+ }
+ }
+ else
+ {
+ my $opt;
+ my %results;
+ if (exists $spec->{'DEFAULT'})
+ {
+ foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
+ {
+ $results{$opt->[0]} = $opt;
+ }
+ }
+ foreach $opt (keys %$spec)
+ {
+ $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
+ }
+ foreach $opt (sort keys %results)
+ {
+ push(@results,$results{$opt});
+ }
+ }
+ }
+ else
+ {
+ my (%args) = @_;
+ my %changed = ();
+ my ($opt,$val);
+ my $config = $cw->TkHash('Configure');
+
+ while (($opt,$val) = each %args)
+ {
+ my $var = \$config->{$opt};
+ my $old = $$var;
+ $$var = $val;
+ my $accepted = 0;
+ my $error = "No widget handles $opt";
+ foreach my $subwidget ($cw->Subconfigure($opt))
+ {
+ next unless (defined $subwidget);
+ eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) };
+ if ($@)
+ {
+ my $val2 = (defined $val) ? $val : 'undef';
+ $error = "Can't set $opt to `$val2' for $cw: " . $@;
+ undef $@;
+ }
+ else
+ {
+ $accepted = 1;
+ }
+ }
+ $cw->BackTrace($error) unless ($accepted);
+ $val = $$var;
+ $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val");
+ }
+ $cw->Configured(\%args,\%changed);
+ }
+ return (wantarray) ? @results : \@results;
+}
+
+sub ConfigDefault
+{
+ my ($cw,$args) = @_;
+
+ $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH');
+
+ my $specs = $cw->ConfigSpecs;
+ # Should we enforce a Delagates(DEFAULT => ) as well ?
+ $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
+
+ #
+ # This is a pain with Text or Entry as core widget, they don't
+ # inherit SELF's cursor. So comment it out for Tk402.001
+ #
+ # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
+
+ # Now some hacks that cause colours to propogate down a composite widget
+ # tree - really needs more thought, other options adding such as active
+ # colours too and maybe fonts
+
+ my $child = ($cw->children)[0]; # 1st child window (if any)
+
+ unless (exists($specs->{'-background'}))
+ {
+ Tk::catch { $cw->Tk::cget('-background') };
+ my (@bg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@bg,'CHILDREN') if $child;
+ $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
+ }
+ unless (exists($specs->{'-foreground'}))
+ {
+ Tk::catch { $cw->Tk::cget('-foreground') };
+ my (@fg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@fg,'CHILDREN') if $child;
+ $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK];
+ }
+ $cw->ConfigAlias(-fg => '-foreground', -bg => '-background');
+
+ # Pre-scan args for aliases - this avoids defaulting
+ # options specified via alias
+ foreach my $opt (keys %$args)
+ {
+ my $info = $specs->{$opt};
+ if (defined($info) && !ref($info))
+ {
+ $args->{$info} = delete $args->{$opt};
+ }
+ }
+
+ # Now walk %$specs supplying defaults for all the options
+ # which have a defined default value, potentially looking up .Xdefaults database
+ # options for the name/class of the 'frame'
+
+ foreach my $opt (keys %$specs)
+ {
+ if ($opt ne 'DEFAULT')
+ {
+ unless (exists $args->{$opt})
+ {
+ my $info = $specs->{$opt};
+ if (ref $info)
+ {
+ # Not an alias
+ if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
+ {
+ # configure inquire to fill in default slot from subwidget
+ $cw->configure($opt);
+ }
+ if (defined $info->[3])
+ {
+ if (defined $info->[1] && defined $info->[2])
+ {
+ # Should we do this on the Subconfigure widget instead?
+ # to match *Entry.Background
+ my $db = $cw->optionGet($info->[1],$info->[2]);
+ $info->[3] = $db if (defined $db);
+ }
+ $args->{$opt} = $info->[3];
+ }
+ }
+ }
+ }
+ }
+}
+
+sub ConfigSpecs
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('ConfigSpecs');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub _alias
+{
+ my ($specs,$opt,$main) = @_;
+ if (exists($specs->{$opt}))
+ {
+ unless (exists $specs->{$main})
+ {
+ my $targ = $specs->{$opt};
+ if (ref($targ))
+ {
+ # opt is a real option
+ $specs->{$main} = $opt
+ }
+ else
+ {
+ # opt is itself an alias
+ # make main point to same place
+ $specs->{$main} = $targ unless $targ eq $main;
+ }
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub ConfigAlias
+{
+ my $cw = shift;
+ my $specs = $cw->ConfigSpecs;
+ while (@_ >= 2)
+ {
+ my $opt = shift;
+ my $main = shift;
+ unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt))
+ {
+ $cw->BackTrace("Neither $opt nor $main exist");
+ }
+ }
+ $cw->BackTrace('Odd number of args to ConfigAlias') if (@_);
+}
+
+sub Delegate
+{
+ my ($cw,$method,@args) = @_;
+ my $widget = $cw->DelegateFor($method);
+ if ($widget == $cw)
+ {
+ $method = "Tk::Widget::$method"
+ }
+ my @result;
+ if (wantarray)
+ {
+ @result = $widget->$method(@args);
+ }
+ else
+ {
+ $result[0] = $widget->$method(@args);
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub InitObject
+{
+ my ($cw,$args) = @_;
+ $cw->Populate($args);
+ $cw->ConfigDefault($args);
+}
+
+sub ConfigChanged
+{
+ my ($cw,$args) = @_;
+}
+
+sub Advertise
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ my $hash = $cw->TkHash('SubWidget');
+ $hash->{$name} = $widget; # advertise it
+ return $widget;
+}
+
+sub Component
+{
+ my ($cw,$kind,$name,%args) = @_;
+ $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
+ # my $pack = delete $args{'-pack'};
+ my $delegate = delete $args{'-delegate'};
+ my $w = $cw->$kind(%args); # Create it
+ # $w->pack(@$pack) if (defined $pack);
+ $cw->Advertise($name,$w) if (defined $name);
+ $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate);
+ return $w; # and return it
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Dialog.pm b/Master/tlpkg/tlperl/lib/Tk/Dialog.pm
new file mode 100644
index 00000000000..8173f4a5acc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Dialog.pm
@@ -0,0 +1,70 @@
+package Tk::Dialog;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $
+
+# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on
+# John Stoffel's idea).
+#
+# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27
+# lusol@Lehigh.EDU
+
+# Documentation after __END__
+
+use Carp;
+use strict;
+use base qw(Tk::DialogBox);
+
+Construct Tk::Widget 'Dialog';
+
+sub Populate
+{
+
+ # Dialog object constructor. Uses `new' method from base class
+ # to create object container then creates the dialog toplevel.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+
+ my ($w_bitmap,$w_but,$pad1,$pad2);
+
+ # Create the Toplevel window and divide it into top and bottom parts.
+
+ my (@pl) = (-side => 'top', -fill => 'both');
+
+ ($pad1, $pad2) =
+ ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']);
+
+
+ $cw->iconname('Dialog');
+
+ my $w_top = $cw->Subwidget('top');
+
+ # Fill the top part with the bitmap and message.
+
+ @pl = (-side => 'left');
+
+ $w_bitmap = $w_top->Label(Name => 'bitmap');
+ $w_bitmap->pack(@pl, @$pad1);
+
+ my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' );
+
+ $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1);
+
+ $cw->Advertise(message => $w_msg);
+ $cw->Advertise(bitmap => $w_bitmap );
+
+ $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef],
+ -bitmap => ['bitmap',undef,undef,undef],
+ -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'],
+ DEFAULT => ['message',undef,undef,undef]
+ );
+}
+
+1;
+
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm b/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm
new file mode 100644
index 00000000000..13335404e15
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DialogBox.pm
@@ -0,0 +1,135 @@
+#
+# DialogBox is similar to Dialog except that it allows any widget
+# in the top frame. Widgets can be added with the add method. Currently
+# there exists no way of deleting a widget once it has been added.
+
+package Tk::DialogBox;
+
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Toplevel);
+
+Tk::Widget->Construct('DialogBox');
+
+sub Populate {
+ my ($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ my $buttons = delete $args->{'-buttons'};
+ $buttons = ['OK'] unless defined $buttons;
+ my $default_button = delete $args->{'-default_button'};
+ $default_button = $buttons->[0] unless defined $default_button;
+
+ $cw->{'selected_button'} = '';
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ if (@$buttons == 1) {
+ $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke });
+ } else {
+ $cw->protocol('WM_DELETE_WINDOW' => sub {});
+ }
+
+ # create the two frames
+ my $top = $cw->Component('Frame', 'top');
+ $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ my $bot = $cw->Component('Frame', 'bottom');
+ $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/);
+ $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
+
+ # create a row of buttons in the bottom.
+ my $bl; # foreach my $var: perl > 5.003_08
+ foreach $bl (@$buttons)
+ {
+ my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } );
+ $b->bind('<Return>' => [ $b, 'Invoke']);
+ $cw->Advertise("B_$bl" => $b);
+ if ($Tk::platform eq 'MSWin32')
+ {
+ $b->configure(-width => 10, -pady => 0);
+ }
+ if ($bl eq $default_button) {
+ if ($Tk::platform eq 'MSWin32') {
+ $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ } else {
+ my $db = $bot->Frame(-relief => 'sunken', -bd => 1);
+ $b->raise($db);
+ $b->pack(-in => $db, -padx => '2', -pady => '2');
+ $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ }
+ $cw->{'default_button'} = $b;
+ $cw->bind('<Return>' => [ $b, 'Invoke']);
+ } else {
+ $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ }
+ }
+ $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ],
+ -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'],
+ -background => ['DESCENDANTS', 'background','Background', undef],
+ -focus => ['PASSIVE', undef, undef, undef],
+ -showcommand => ['CALLBACK', undef, undef, undef],
+ );
+ $cw->Delegates('Construct',$top);
+}
+
+sub add {
+ my ($cw, $wnam, @args) = @_;
+ my $w = $cw->Subwidget('top')->$wnam(@args);
+ $cw->Advertise("\L$wnam" => $w);
+ return $w;
+}
+
+sub Wait
+{
+ my $cw = shift;
+ $cw->Callback(-showcommand => $cw);
+ $cw->waitVariable(\$cw->{'selected_button'});
+ $cw->grabRelease;
+ $cw->withdraw;
+ $cw->Callback(-command => $cw->{'selected_button'});
+}
+
+sub Show {
+
+ croak 'DialogBox: "Show" method requires at least 1 argument'
+ if scalar @_ < 1;
+ my $cw = shift;
+ my ($grab) = @_;
+ my $old_focus = $cw->focusSave;
+ my $old_grab = $cw->grabSave;
+
+ shift if defined $grab && length $grab && ($grab =~ /global/);
+ $cw->Popup(@_);
+
+ Tk::catch {
+ if (defined $grab && length $grab && ($grab =~ /global/)) {
+ $cw->grabGlobal;
+ } else {
+ $cw->grab;
+ }
+ };
+ if (my $focusw = $cw->cget(-focus)) {
+ $focusw->focus;
+ } elsif (defined $cw->{'default_button'}) {
+ $cw->{'default_button'}->focus;
+ } else {
+ $cw->focus;
+ }
+ $cw->Wait;
+ &$old_focus;
+ &$old_grab;
+ return $cw->{'selected_button'};
+}
+
+sub Exit
+{
+ my $cw = shift;
+ #kill the dialogbox, by faking a 'DONE'
+ $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DirTree.pm b/Master/tlpkg/tlperl/lib/Tk/DirTree.pm
new file mode 100644
index 00000000000..b2d996a94d0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DirTree.pm
@@ -0,0 +1,252 @@
+package Tk::DirTree;
+# DirTree -- TixDirTree widget
+#
+# Derived from DirTree.tcl in Tix 4.1
+#
+# Chris Dean <ctdean@cogit.com>
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk;
+use Tk::Derived;
+use Tk::Tree;
+use Cwd;
+use DirHandle;
+
+use base qw(Tk::Derived Tk::Tree);
+use strict;
+
+Construct Tk::Widget 'DirTree';
+
+
+sub Populate {
+ my( $cw, $args ) = @_;
+
+ $cw->SUPER::Populate( $args );
+
+ $cw->ConfigSpecs(
+ -dircmd => [qw/CALLBACK dirCmd DirCmd DirCmd/],
+ -showhidden => [qw/PASSIVE showHidden ShowHidden 0/],
+ -image => [qw/PASSIVE image Image folder/],
+ -directory => [qw/SETMETHOD directory Directory ./],
+ -value => '-directory' );
+
+ $cw->configure( -separator => '/', -itemtype => 'imagetext' );
+}
+
+sub DirCmd {
+ my( $w, $dir, $showhidden ) = @_;
+ $dir .= "/" if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
+ my $h = DirHandle->new( $dir ) or return();
+ my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
+ @names = grep( ! /^[.]/, @names ) unless $showhidden;
+ return( @names );
+}
+
+*dircmd = \&DirCmd;
+
+sub fullpath
+{
+ my ($path) = @_;
+ my $cwd = getcwd();
+ if (CORE::chdir($path))
+ {
+ $path = getcwd();
+ CORE::chdir($cwd) || die "Cannot cd back to $cwd:$!";
+ }
+ else
+ {
+ warn "Cannot cd to $path:$!"
+ }
+ return $path;
+}
+
+sub directory
+{
+ my ($w,$key,$val) = @_;
+ # We need a value for -image, so its being undefined
+ # is probably caused by order of handling config defaults
+ # so defer it.
+ $w->afterIdle([$w, 'set_dir' => $val]);
+}
+
+sub set_dir {
+ my( $w, $val ) = @_;
+ my $fulldir = fullpath( $val );
+
+ my $parent = '/';
+ if ($^O eq 'MSWin32')
+ {
+ if ($fulldir =~ s/^([a-z]:)//i)
+ {
+ $parent = $1;
+ }
+ }
+ $w->add_to_tree( $parent, $parent) unless $w->infoExists($parent);
+
+ my @dirs = ($parent);
+ foreach my $name (split( /[\/\\]/, $fulldir )) {
+ next unless length $name;
+ push @dirs, $name;
+ my $dir = join( '/', @dirs );
+ $dir =~ s|^//|/|;
+ $w->add_to_tree( $dir, $name, $parent )
+ unless $w->infoExists( $dir );
+ $parent = $dir;
+ }
+
+ $w->OpenCmd( $parent );
+ $w->setmode( $parent, 'close' );
+}
+*chdir = \&set_dir;
+
+
+sub OpenCmd {
+ my( $w, $dir ) = @_;
+
+ my $parent = $dir;
+ $dir = '' if $dir eq '/';
+ foreach my $name ($w->dirnames( $parent )) {
+ next if ($name eq '.' || $name eq '..');
+ my $subdir = "$dir/$name";
+ next unless -d $subdir;
+ if( $w->infoExists( $subdir ) ) {
+ $w->show( -entry => $subdir );
+ } else {
+ $w->add_to_tree( $subdir, $name, $parent );
+ }
+ }
+}
+
+*opencmd = \&OpenCmd;
+
+sub add_to_tree {
+ my( $w, $dir, $name, $parent ) = @_;
+
+ my $image = $w->cget('-image');
+ if ( !UNIVERSAL::isa($image, 'Tk::Image') ) {
+ $image = $w->Getimage( $image );
+ }
+ my $mode = 'none';
+ $mode = 'open' if $w->has_subdir( $dir );
+
+ my @args = (-image => $image, -text => $name);
+ if( $parent ) { # Add in alphabetical order.
+ foreach my $sib ($w->infoChildren( $parent )) {
+ if( $sib gt $dir ) {
+ push @args, (-before => $sib);
+ last;
+ }
+ }
+ }
+
+ $w->add( $dir, @args );
+ $w->setmode( $dir, $mode );
+}
+
+sub has_subdir {
+ my( $w, $dir ) = @_;
+ foreach my $name ($w->dirnames( $dir )) {
+ next if ($name eq '.' || $name eq '..');
+ next if ($name =~ /^\.+$/);
+ return( 1 ) if -d "$dir/$name";
+ }
+ return( 0 );
+}
+
+sub dirnames {
+ my( $w, $dir ) = @_;
+ my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
+ return( @names );
+}
+
+{
+ package Tk::DirTreeDialog;
+ use base qw(Tk::Toplevel);
+ Construct Tk::Widget 'DirTreeDialog';
+
+ sub Populate {
+ my($w, $args) = @_;
+ $w->{curr_dir} = $args->{-initialdir};
+ if (!defined $w->{curr_dir}) {
+ require Cwd;
+ $w->{curr_dir} = Cwd::cwd();
+ }
+ if (defined $args->{-mustexist}) {
+ die "-mustexist is not yet implemented";
+ }
+ my $title = $args->{-title} || "Choose directory:";
+ delete $args->{-popover};
+
+ $w->title($title);
+ $w->{ok} = 0; # flag: "1" means OK, "-1" means cancelled
+
+ # Create Frame widget before the DirTree widget, so it's always visible
+ # if the window gets resized.
+ my $f = $w->Frame->pack(-fill => "x", -side => "bottom");
+
+ my $d;
+ $d = $f->Scrolled('DirTree',
+ -scrollbars => 'osoe',
+ -width => 35,
+ -height => 20,
+ -selectmode => 'browse',
+ -exportselection => 1,
+ -browsecmd => sub {
+ $w->{curr_dir} = shift;
+ if ($^O ne 'MSWin32') {
+ $w->{curr_dir} =~ s|^//|/|; # bugfix
+ }
+ },
+
+ # With this version of -command a double-click will
+ # select the directory
+ -command => sub { $w->{ok} = 1 },
+
+ # With this version of -command a double-click will
+ # open a directory. Selection is only possible with
+ # the Ok button.
+ #-command => sub { $d->opencmd($_[0]) },
+ )->pack(-fill => "both", -expand => 1);
+ # Set the initial directory
+ exists &Tk::DirTree::chdir ? $d->chdir($w->{curr_dir}) : $d->set_dir($w->{curr_dir});
+
+ $f->Button(-text => 'Ok',
+ -command => sub { $w->{ok} = 1 })->pack(-side => 'left');
+ $f->Button(-text => 'Cancel',
+ -command => sub { $w->{ok} = -1 })->pack(-side => 'left');
+ $w->OnDestroy(sub { $w->{ok} = -1 });
+ }
+
+ sub Show {
+ my $w = shift;
+ my $old_focus = $w->focusSave;
+ my $old_grab = $w->grabSave;
+ Tk::catch {
+ $w->grab;
+ };
+ $w->waitVariable(\$w->{ok});
+ my $ret = $w->{ok} == 1 ? $w->{curr_dir} : undef;
+ $w->grabRelease if Tk::Exists($w);
+ &$old_focus;
+ &$old_grab;
+ $w->destroy if Tk::Exists($w);
+ $ret;
+ }
+}
+
+1;
+
+__END__
+
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distrobution are in the file
+# license.tcl.
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm b/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm
new file mode 100644
index 00000000000..f16ce021f41
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Dirlist.pm
@@ -0,0 +1,113 @@
+package Tk::Dirlist;
+require Tk::Derived;
+require Tk::HList;
+require DirHandle;
+use Cwd;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dirlist.pm#5 $
+
+use base qw(Tk::Derived Tk::HList);
+use strict;
+Construct Tk::Widget 'Dirlist';
+
+sub getimage
+{
+ my ($w,$key) = @_;
+ unless (exists $w->{$key})
+ {
+ $w->{$key} = $w->Pixmap(-id => $key);
+ unless ($w->{$key})
+ {
+ $w->{$key} = $w->Bitmap($key);
+ }
+ }
+ return $w->{$key};
+}
+
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->configure(-separator => '/', -itemtype => 'imagetext');
+ $cw->ConfigSpecs(-directory => ['SETMETHOD','directory','Directory','.']);
+}
+
+sub fullpath
+{
+ my ($path) = @_;
+ my $cwd = getcwd;
+ if (chdir($path))
+ {
+ $path = getcwd;
+ chdir($cwd);
+ }
+ else
+ {
+ warn "Cannot cd to $path:$!"
+ }
+# print "$path\n";
+ return $path;
+}
+
+sub AddDir
+{
+ my ($w,$dir) = @_;
+ my $path = '';
+ my $prefix = '';
+ my $first = 0;
+ my $name;
+ foreach $name (split m#/#,$dir)
+ {
+ $first++;
+ if ($name eq '')
+ {
+ next unless ($first == 1);
+ $path = '/';
+ $name = '/';
+ }
+ else
+ {
+ $path .= $prefix;
+ $path .= $name;
+ $prefix = '/';
+ }
+ unless ($w->info('exists' => $path))
+ {
+# print "Add $path\n";
+ $w->add($path,-image => $w->getimage('folder'), -text => $name);
+ }
+ }
+}
+
+sub choose_image
+{
+ my ($w,$path) = @_;
+ return 'folder' if (-d $path);
+ return 'srcfile' if ($path =~ /\.[ch]$/);
+ return 'textfile' if (-T $path);
+ return 'file';
+}
+
+
+sub directory
+{
+ my ($w,$key,$val) = @_;
+ my $h = DirHandle->new($val);
+ $w->AddDir($val = fullpath($val));
+ my $f;
+ $w->entryconfigure($val,-image => $w->getimage('act_fold'));
+ foreach $f (sort $h->read)
+ {
+ next if ($f =~ /^\.+$/);
+ my $path = "$val/$f";
+ unless ($w->info('exists' => $path))
+ {
+ my $image = $w->getimage($w->choose_image($path));
+ $w->add($path,-image => $image, -text => $f);
+ }
+ }
+ $h->close;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm
new file mode 100644
index 00000000000..bdc54f74367
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop.pm
@@ -0,0 +1,332 @@
+package Tk::DragDrop;
+require Tk::DragDrop::Common;
+require Tk::Toplevel;
+require Tk::Label;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Common Tk::Toplevel);
+
+# This is a little tricky, ISA says 'Toplevel' but we
+# define a Tk_cmd to actually build a 'Label', then
+# use wmRelease in Populate to make it a toplevel.
+
+my $useWmRelease = Tk::Wm->can('release'); # ($^O ne 'MSWin32');
+
+sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel }
+
+Construct Tk::Widget 'DragDrop';
+
+use strict;
+use vars qw(%type @types);
+use Carp;
+
+
+# There is a snag with having a token window and moving to
+# exactly where cursor is - the cursor is "inside" the token
+# window - hence it is not "inside" the dropsite window
+# so we offset X,Y by OFFSET pixels.
+sub OFFSET () {3}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Map>','Mapped');
+ $mw->bind($class,'<Any-KeyPress>','Done');
+ $mw->bind($class,'<Any-ButtonRelease>','Drop');
+ $mw->bind($class,'<Any-Motion>','Drag');
+ return $class;
+}
+
+sub Populate
+{
+ my ($token,$args) = @_;
+ my $parent = $token->parent;
+ if ($useWmRelease)
+ {
+ $token->wmRelease;
+ $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]);
+ }
+ else
+ {
+ my $lab = $token->Label->pack(-expand => 1, -fill => 'both');
+ bless $lab,ref($token);
+ $lab->bindtags([ref($token), $lab, $token, 'all']);
+ $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class],
+ DEFAULT => [$lab]);
+ }
+ $token->withdraw;
+ $token->overrideredirect(1);
+ $token->ConfigSpecs(-sitetypes => ['METHOD','siteTypes','SiteTypes',undef],
+ -startcommand => ['CALLBACK',undef,undef,undef],
+ -endcommand => ['CALLBACK',undef,undef,undef],
+ -predropcommand => ['CALLBACK',undef,undef,undef],
+ -postdropcommand => ['CALLBACK',undef,undef,undef],
+ -delta => ['PASSIVE','delta','Delta',10],
+ -cursor => ['SELF','cursor','Cursor','hand2'],
+ -handlers => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]],
+ -selection => ['SETMETHOD','selection','Selection','XdndSelection'],
+ -event => ['SETMETHOD','event','Event','<B1-Motion>']
+ );
+ $token->{InstallHandlers} = 0;
+ $args->{-borderwidth} = 3;
+ $args->{-relief} = 'flat';
+ $args->{-takefocus} = 1;
+}
+
+sub sitetypes
+{
+ my ($w,$val) = @_;
+ confess "Not a widget $w" unless (ref $w);
+ my $var = \$w->{Configure}{'-sitetypes'};
+ if (@_ > 1)
+ {
+ if (defined $val)
+ {
+ $val = [$val] unless (ref $val);
+ my $type;
+ foreach $type (@$val)
+ {
+ Tk::DragDrop->import($type);
+ }
+ }
+ $$var = $val;
+ }
+ return (defined $$var) ? $$var : \@types;
+}
+
+sub SendText
+{
+ my ($w,$offset,$max) = @_;
+ my $s = substr($w->cget('-text'),$offset);
+ $s = substr($s,0,$max) if (length($s) > $max);
+ return $s;
+}
+
+sub handlers
+{
+ my ($token,$opt,$value) = @_;
+ $token->{InstallHandlers} = (defined($value) && @$value);
+ $token->{'handlers'} = $value;
+}
+
+sub selection
+{
+ my ($token,$opt,$value) = @_;
+ my $handlers = $token->{'handlers'};
+ $token->{InstallHandlers} = (defined($handlers) && @$handlers);
+}
+
+sub event
+{
+ my ($w,$opt,$value) = @_;
+ # delete old bindings
+ $w->parent->Tk::bind($value,[$w,'StartDrag']);
+}
+
+#
+
+sub FindSite
+{
+ my ($token,$X,$Y,$e) = @_;
+ my $site;
+ my $types = $token->sitetypes;
+ if (defined $types && @$types)
+ {
+ foreach my $type (@$types)
+ {
+ my $class = $type{$type};
+ last if (defined($class) && ($site = $class->FindSite($token,$X,$Y)));
+ }
+ }
+ else
+ {
+ warn 'No sitetypes';
+ }
+ my $new = $site || 'undef';
+ my $over = $token->{'Over'};
+ if ($over)
+ {
+ if (!$over->Match($site))
+ {
+ $over->Leave($token,$e);
+ delete $token->{'Over'};
+ }
+ }
+ if ($site)
+ {
+ unless ($token->{'Over'})
+ {
+ $site->Enter($token,$e);
+ $token->{'Over'} = $site;
+ }
+ $site->Motion($token,$e) if (defined $site)
+ }
+ return $site;
+}
+
+sub Mapped
+{
+ my ($token) = @_;
+ my $e = $token->parent->XEvent;
+ $token = $token->toplevel;
+ $token->grabGlobal;
+ $token->focus;
+ if (defined $e)
+ {
+ my $X = $e->X;
+ my $Y = $e->Y;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->NewDrag;
+ $token->FindSite($X,$Y,$e);
+ }
+}
+
+sub NewDrag
+{
+ my ($token) = @_;
+ my $types = $token->sitetypes;
+ if (defined $types && @$types)
+ {
+ my $type;
+ foreach $type (@$types)
+ {
+ my $class = $type{$type};
+ if (defined $class)
+ {
+ $class->NewDrag($token);
+ }
+ }
+ }
+}
+
+sub Drag
+{
+ my $token = shift;
+ my $e = $token->XEvent;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ $token = $token->toplevel;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->FindSite($X,$Y,$e);
+}
+
+sub Done
+{
+ my $token = shift;
+ my $e = $token->XEvent;
+ $token = $token->toplevel;
+ my $over = delete $token->{'Over'};
+ $over->Leave($token,$e) if (defined $over);
+ my $w = $token->parent;
+ eval {local $SIG{__DIE__}; $token->grabRelease };
+ $token->withdraw;
+ delete $w->{'Dragging'};
+ $w->update;
+}
+
+sub AcceptDrop
+{
+ my ($token) = @_;
+ $token->configure(-relief => 'sunken');
+ $token->{'Accepted'} = 1;
+}
+
+sub RejectDrop
+{
+ my ($token) = @_;
+ $token->configure(-relief => 'flat');
+ $token->{'Accepted'} = 0;
+}
+
+sub HandleLoose
+{
+ my ($w,$seln) = @_;
+ return '';
+}
+
+sub InstallHandlers
+{
+ my ($token,$seln) = @_;
+ my $w = $token->parent;
+ $token->configure('-selection' => $seln) if $seln;
+ $seln = $token->cget('-selection');
+ if ($token->{InstallHandlers})
+ {
+ foreach my $h (@{$token->cget('-handlers')})
+ {
+ $w->SelectionHandle('-selection' => $seln,@$h);
+ }
+ $token->{InstallHandlers} = 0;
+ }
+ if (!$w->IS($w->SelectionOwner('-selection'=>$seln)))
+ {
+ $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]);
+ }
+}
+
+sub Drop
+{
+ my $ewin = shift;
+ my $e = $ewin->XEvent;
+ my $token = $ewin->toplevel;
+ my $site = $token->FindSite($e->X,$e->Y,$e);
+ Tk::catch { $token->grabRelease };
+ if (defined $site)
+ {
+ my $seln = $token->cget('-selection');
+ unless ($token->Callback(-predropcommand => $seln, $site))
+ {
+# XXX This is ugly if the user restarts a drag within the 2000 ms:
+# my $id = $token->after(2000,[$token,'Done']);
+ my $w = $token->parent;
+ $token->InstallHandlers;
+ $site->Drop($token,$seln,$e);
+ $token->Callback(-postdropcommand => $seln);
+ $token->Done;
+ }
+ }
+ else
+ {
+ $token->Done;
+ }
+ $token->Callback('-endcommand');
+}
+
+sub StartDrag
+{
+ my $token = shift;
+ my $w = $token->parent;
+ unless ($w->{'Dragging'})
+ {
+ my $e = $w->XEvent;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ my $was = $token->{'XY'};
+ if ($was)
+ {
+ my $dx = $was->[0] - $X;
+ my $dy = $was->[1] - $Y;
+ if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta'))
+ {
+ unless ($token->Callback('-startcommand',$token,$e))
+ {
+ delete $token->{'XY'};
+ $w->{'Dragging'} = $token;
+ $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
+ $token->raise;
+ $token->deiconify;
+ $token->FindSite($X,$Y,$e);
+ }
+ }
+ }
+ else
+ {
+ $token->{'XY'} = [$X,$Y];
+ }
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
new file mode 100644
index 00000000000..2f7a33d4fb4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
@@ -0,0 +1,59 @@
+package Tk::DragDrop::Common;
+
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/Common.pm#4 $
+
+sub Type
+{
+ my ($base,$name,$class) = @_;
+ no strict 'refs';
+ my $hash = \%{"${base}::type"};
+ my $array = \@{"${base}::types"};
+ unless (exists $hash->{$name})
+ {
+ push(@$array,$name);
+ $class = (caller(0))[0] unless (@_ > 2);
+ $hash->{$name} = $class;
+ # confess "Strange class $class for $base/$name" unless ($class =~ /^Tk/);
+ # print "$base $name is ",$class,"\n";
+ }
+}
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $types = \%{"${class}::type"};
+ while (@_)
+ {
+ my $type = shift;
+ unless (exists $types->{$type})
+ {
+ if ($type eq 'Local')
+ {
+ $class->Type($type,$class);
+ }
+ else
+ {
+ my ($kind) = $class =~ /([A-Z][a-z]+)$/;
+ my $file = Tk->findINC("DragDrop/${type}${kind}.pm");
+ if (defined $file)
+ {
+ # print "Loading $file\n";
+ require $file;
+ }
+ else
+ {
+ croak "Cannot find ${type}${kind}";
+ }
+ }
+ }
+ }
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm
new file mode 100644
index 00000000000..0f5028ae64c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm
@@ -0,0 +1,61 @@
+package Tk::DragDrop::Local;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/LocalDrop.pm#4 $
+
+use base qw(Tk::DragDrop::Rect);
+require Tk::DragDrop;
+
+my @toplevels;
+
+Tk::DragDrop->Type('Local');
+
+sub XY
+{
+ my ($site,$event) = @_;
+ return ($event->X - $site->X,$event->Y - $site->Y);
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $event = shift;
+ $cb->Call(@_,$site->XY($event));
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ $site->Apply(-dropcommand => $event, $seln);
+ $site->Apply(-entercommand => $event, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event);
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm
new file mode 100644
index 00000000000..04cfa8772f2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm
@@ -0,0 +1,110 @@
+package Tk::DragDrop::Rect;
+use strict;
+use Carp;
+
+# Proxy class which represents sites to the dropping side
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
+
+# Some default methods when called site side
+# XIDs and viewable-ness from widget
+
+# XID of ancestor
+sub ancestor { ${shift->widget->toplevel->WindowId} }
+
+# XID of site window
+sub win { ${shift->widget->WindowId} }
+
+# Is site window mapped
+sub viewable { shift->widget->viewable }
+
+sub Over
+{
+ my ($site,$X,$Y) = @_;
+
+ my $x = $site->X;
+ my $y = $site->Y;
+ my $w = $site->width;
+ my $h = $site->height;
+ my $val = ($X >= $x && $X < ($x + $w) && $Y >= $y && $Y < ($y + $h));
+
+ return 0 unless $val;
+
+ my $widget = $site->widget;
+
+ # Now XTranslateCoords from root window to site window's
+ # ancestor. Ancestors final descendant should be the site window.
+ # Like $win->containing but avoids a problem that dropper's "token"
+ # window may be the toplevel (child of root) that contains X,Y
+ # so if that is in another application ->containing does not
+ # give us a window.
+ my $id = $site->ancestor;
+ while (1)
+ {
+ my $cid = $widget->PointToWindow($X,$Y,$id);
+ last unless $cid;
+ $id = $cid;
+ }
+ return ($id == $site->win);
+}
+
+sub FindSite
+{
+ my ($class,$widget,$X,$Y) = @_;
+ foreach my $site ($class->SiteList($widget))
+ {
+ return $site if ($site->viewable && $site->Over($X,$Y));
+ }
+ return undef;
+}
+
+sub NewDrag
+{
+ my ($class,$widget) = @_;
+}
+
+sub Match
+{
+ my ($site,$other) = @_;
+ return 0 unless (defined $other);
+ return 1 if ($site == $other);
+ return 0 unless (ref($site) eq ref($other));
+ for ("$site")
+ {
+ if (/ARRAY/)
+ {
+ my $i;
+ return 0 unless (@$site == @$other);
+ for ($i = 0; $i < @$site; $i++)
+ {
+ return 0 unless ($site->[$i] == $other->[$i]);
+ }
+ return 1;
+ }
+ elsif (/SCALAR/)
+ {
+ return $site == $other;
+ }
+ elsif (/HASH/)
+ {
+ my $key;
+ foreach $key (keys %$site)
+ {
+ return 0 unless exists $other->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ foreach $key (keys %$other)
+ {
+ return 0 unless exists $site->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ return 1;
+ }
+ return 0;
+ }
+ return 0;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm
new file mode 100644
index 00000000000..66325466e68
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm
@@ -0,0 +1,34 @@
+package Tk::DragDrop::SunConst;
+require Exporter;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/SunConst.pm#4 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(_enter _leave _motion
+ ENTERLEAVE MOTION DEFAULT_SITE
+ MOVE_FLAG ACK_FLAG TRANSIENT_FLAG FORWARDED_FLAG
+ );
+
+# Event types
+sub _enter () {7};
+sub _leave () {8};
+sub _motion () {6};
+
+# Site flags
+
+sub ENTERLEAVE () {1<<0}
+sub MOTION () {1<<1}
+sub DEFAULT_SITE () {1<<2}
+
+# Trigger flags
+sub MOVE_FLAG () {1<<0}
+sub ACK_FLAG () {1<<1}
+sub TRANSIENT_FLAG () {1<<2}
+sub FORWARDED_FLAG () {1<<3}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm
new file mode 100644
index 00000000000..422a08196ea
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm
@@ -0,0 +1,200 @@
+package Tk::DragDrop::SunDrop;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Rect);
+use strict;
+use Tk::DragDrop::SunConst;
+
+Tk::DragDrop->Type('Sun');
+
+BEGIN
+ {
+ # Define the Rect API as members of the array
+ my @fields = qw(name win X Y width height flags ancestor widget);
+ my $i = 0;
+ no strict 'refs';
+ for ($i=0; $i < @fields; $i++)
+ {
+ my $j = $i;
+ *{"$fields[$i]"} = sub { shift->[$j] };
+ }
+ }
+
+
+sub Preview
+{
+ my ($site,$token,$e,$kind,$flags) = (@_);
+ $token->BackTrace('No flags') unless defined $flags;
+ my $sflags = $site->flags;
+ return if ($kind == _motion && !($sflags & MOTION));
+ return if ($kind != _motion && !($sflags & ENTERLEAVE));
+ my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ $token->AcceptDrop;
+ $site->Preview($token,$e,_enter,0);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ $token->RejectDrop;
+ $site->Preview($token,$e,_leave,0);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ $site->Preview($token,$e,_motion,0);
+}
+
+sub HandleDone
+{
+ my ($token,$seln,$offset,$max) = @_;
+ $token->Done;
+ return '';
+}
+
+sub HandleAck
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return '';
+}
+
+sub HandleItem
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return undef;
+}
+
+sub HandleCount
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return 1;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]);
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]);
+ my $atom = $w->InternAtom($seln);
+ my $flags = ACK_FLAG | TRANSIENT_FLAG;
+ my $data = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ $token->{'SunDD'} = [] unless exists $token->{'SunDD'};
+ my $site = $class->SUPER::FindSite($token,$X,$Y);
+ if (!defined $site)
+ {
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) };
+ if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0)
+ {
+ # This is a "toplevel" which has some sites associated with it.
+ my ($bx,$by) = $token->WindowXY($id);
+ $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'};
+ return $site if $token->{'SunDDSeen'}{$id};
+ $token->{'SunDDSeen'}{$id} = 1;
+ my $sites = $token->{'SunDD'};
+ my $count = shift(@prop);
+ while (@prop && $count-- > 0)
+ {
+ my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5);
+ if ($kind != 0)
+ {
+ warn "Don't understand site type $kind";
+ last;
+ }
+ while (@prop >= 4 && $n-- > 0)
+ {
+ my ($x,$y,$w,$h) = splice(@prop,0,4);
+ push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags,$id,$token],$class);
+ }
+ }
+ return $class->SUPER::FindSite($token,$X,$Y);
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ }
+ return $site;
+}
+
+my $busy = 0;
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ delete $token->{'SunDD'} unless $busy;
+ delete $token->{'SunDDSeen'};
+}
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ return @{$token->{'SunDD'}};
+}
+
+1;
+__END__
+
+# this code is obsolete now that we look at properties ourselves
+# which means we don't need dropsite manager running
+# On Sun's running OpenLook the window manager or dropsite mananger
+# watches for and caches site info in a special selection
+# This code got sites from that
+#
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ unless (1 || $busy || exists $token->{'SunDD'})
+ {
+ Carp::confess('Already doing it!') if ($busy++);
+ my @data = ();
+ my @sites = ();
+ my $mw = $token->MainWindow;
+ $token->{'SunDD'} = \@sites;
+ Tk::catch {
+ @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM', '_SUN_DRAGDROP_SITE_RECTS');
+ };
+ if ($@)
+ {
+ $token->configure('-cursor'=>'hand2');
+ $token->grab(-global);
+ }
+ else
+ {
+ while (@data)
+ {
+ my $version = shift(@data);
+ if ($version != 0)
+ {
+ warn "Unexpected site version $version";
+ last;
+ }
+ push(@sites,bless [splice(@data,0,7)],$class);
+ }
+ }
+ $busy--;
+ }
+ return @{$token->{'SunDD'}};
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm
new file mode 100644
index 00000000000..ab3f4f9793b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm
@@ -0,0 +1,107 @@
+package Tk::DragDrop::SunSite;
+require Tk::DropSite;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+
+use Tk::DragDrop::SunConst;
+use base qw(Tk::DropSite);
+use strict;
+
+Tk::DropSite->Type('Sun');
+
+sub SunDrop
+{
+ my ($w,$site) = @_;
+ my $e = $w->XEvent;
+ my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A);
+ $w->MakeAtom($seln);
+ if ($flags & &ACK_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') };
+ }
+ my @targ = $w->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ);
+ if ($flags & &TRANSIENT_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') };
+ }
+ $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'});
+ $site->Apply(-entercommand => $x, $y, 0);
+}
+
+sub SunPreview
+{
+ my ($w,$site) = @_;
+ my $event = $w->XEvent;
+ my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A);
+ $x -= $site->X;
+ $y -= $site->Y;
+ if ($kind == _enter)
+ {
+ $site->Callback(-entercommand => 1, $x, $y);
+ }
+ elsif ($kind == _leave)
+ {
+ $site->Callback(-entercommand => 0, $x, $y);
+ }
+ elsif ($kind == _motion)
+ {
+ $site->Callback(-motioncommand => $x, $y);
+ }
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]);
+ $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]);
+}
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ my $count = @$sites;
+ my @data = (0,0);
+ my ($wrapper,$offset) = $t->wrapper;
+ if ($t->viewable)
+ {
+ my $s;
+ my $i = 0;
+ my @win;
+ my $bx = $t->rootx;
+ my $by = $t->rooty - $offset;
+ $t->MakeWindowExist;
+ foreach $s (@$sites)
+ {
+ my $w = $s->widget;
+ if ($w->viewable)
+ {
+ $w->MakeWindowExist;
+ $data[1]++;
+ push(@data,${$w->WindowId}); # XID
+ push(@data,$i++); # Our 'tag'
+ push(@data,ENTERLEAVE|MOTION); # Flags
+ push(@data,0); # Kind is 'rect'
+ push(@data,1); # Number of rects
+ push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height); # The rect
+ }
+ }
+ }
+ if ($data[1])
+ {
+ $t->property('set',
+ '_SUN_DRAGDROP_INTEREST', # name
+ '_SUN_DRAGDROP_INTEREST', # type
+ 32, # format
+ \@data,$wrapper); # the data
+ }
+ else
+ {
+ $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper);
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm
new file mode 100644
index 00000000000..08a4656ecce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm
@@ -0,0 +1,8 @@
+package Tk::DragDrop::Win32Drop;
+# Dummy placeholder for symetry
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/Win32Site/Win32Drop.pm#4 $
+
+use Tk ();
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
new file mode 100644
index 00000000000..f45d06bc92b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
@@ -0,0 +1,50 @@
+package Tk::DragDrop::Win32Site;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+require DynaLoader;
+require Tk::DropSite;
+
+use base qw(Tk::DropSite DynaLoader);
+
+bootstrap Tk::DragDrop::Win32Site;
+
+use strict;
+
+Tk::DropSite->Type('Win32');
+
+sub WM_DROPFILES () {563}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
+ DragAcceptFiles($w,1);
+}
+
+sub Win32Drop
+{
+ # print join(',',@_),"\n";
+ my ($w,$site,$msg,$wParam,$lParam) = @_;
+ my ($x,$y,@files) = DropInfo($wParam);
+ my $cb = $site->{'-dropcommand'};
+ $site->Apply(-entercommand => $x, $y, 1);
+ if ($cb)
+ {
+ foreach my $file (@files)
+ {
+ # print "$file @ $x,$y\n";
+ $w->clipboardClear;
+ $w->clipboardAppend('--',$file);
+ $cb->Call('CLIPBOARD',Win32Drop => ['STRING'],$x,$y);
+ }
+ }
+ $site->Apply(-entercommand => $x, $y, 0);
+ return 0;
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm
new file mode 100644
index 00000000000..7376c8d69c5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm
@@ -0,0 +1,145 @@
+package Tk::DragDrop::XDNDDrop;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DragDrop::Rect);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DragDrop->Type('XDND');
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ $token->{$class} = {};
+}
+
+sub new
+{
+ my ($class,$token,$id,@prop) = @_;
+ my $ver = $token->InternAtom(shift(@prop));
+ # warn "XDND version $ver ".join(' ',@prop)."\n";
+ $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION;
+ my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class;
+ my $w = $token->parent;
+ $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']);
+ $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']);
+ return $site;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0);
+ $w->SendClientMessage('XdndDrop',$site->{id},32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','XdndAware', $id) };
+ if (!$@ && shift(@prop) eq 'ATOM')
+ {
+ my $hash = $token->{$class};
+ my $site = $hash->{$id};
+ if (!defined $site)
+ {
+ $site = $class->new($token,$id,@prop);
+ $hash->{$id} = $site;
+ }
+ return $site;
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ return undef;
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ $token->InstallHandlers('XdndSelection');
+ my $seln = $token->cget('-selection');
+ my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS')));
+ # print join(' ',@targets),"\n";
+ my $flags = ($site->{ver} << 24);
+ my @atarg = map($token->InternAtom($_),@targets);
+ my $ntarg = @atarg;
+ if ($ntarg > 3)
+ {
+ $flags |= 1;
+ $w->property('set','XdndTypeList','ATOM',32,\@atarg);
+ splice(@atarg,3);
+ }
+ else
+ {
+ splice(@atarg,$ntarg,(0 x 3 - $ntarg));
+ }
+ unshift(@atarg,oct($w->id),$flags);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndEnter',$site->{id},32,$data);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0);
+ $w->SendClientMessage('XdndLeave',$site->{id},32,$data);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ my $w = $token->parent;
+ my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy');
+ my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndPosition',$site->{id},32,$data);
+}
+
+sub XdndFinished
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ # printf "XdndFinished $site\n",
+ $token->Done;
+}
+
+sub XdndStatus
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ my $w = $token->parent;
+ my $event = $w->XEvent;
+ my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A);
+ $action = $w->GetAtomName($action) if $action;
+ $site->{flags} = $flags;
+ $site->{'X'} = $xy >> 16;
+ $site->{'Y'} = $xy & 0xFFFF;
+ $site->{'width'} = $wh >> 16;
+ $site->{'height'} = $wh & 0xFFFF;
+ #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n",
+ # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action;
+ if ($flags & 1)
+ {
+ $token->AcceptDrop;
+ }
+ else
+ {
+ $token->RejectDrop;
+ }
+}
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
new file mode 100644
index 00000000000..4ac75d63c40
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
@@ -0,0 +1,159 @@
+package Tk::DragDrop::XDNDSite;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DropSite);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DropSite->Type('XDND');
+
+sub InitSite
+{my ($class,$site) = @_;
+ my $w = $site->widget;
+}
+
+sub XdndEnter
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ my $ver = ($flags >> 24) & 0xFF;
+ if ($flags & 1)
+ {
+ my @prop;
+ Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
+ @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
+ }
+ else
+ {
+ $t->MakeAtom(@types);
+ }
+ # print "XdndEnter $src $ver @types\n";
+ $t->{"XDND$src"} = { ver => $ver, types => \@types };
+}
+
+sub XdndLeave
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ # print "XdndLeave $src\n";
+ my $info = $t->{"XDND$src"};
+ if ($info)
+ {
+ my $over = $info->{site};
+ if ($over)
+ {
+ my $X = $info->{X};
+ my $Y = $info->{Y};
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ }
+ delete $t->{"XDND$src"};
+}
+
+sub XdndPosition
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
+ $t->MakeAtom($action);
+ my $X = $xy >> 16;
+ my $Y = $xy & 0xFFFF;
+ my $info = $t->{"XDND$src"};
+ $info->{X} = $X;
+ $info->{Y} = $Y;
+ $info->{action} = $action;
+ $info->{t} = $time;
+ my ($id) = $t->wrapper;
+ my $sxy = 0;
+ my $swh = 0;
+ my $sflags = 0;
+ my $saction = 0;
+ my $over = $info->{site};
+ foreach my $site (@$sites)
+ {
+ if ($site->Over($X,$Y))
+ {
+ $sxy = ($site->X << 16) | $site->Y;
+ $swh = ($site->width << 16) | $site->height;
+ $saction = $action;
+ $sflags |= 1;
+ if ($over)
+ {
+ if ($over == $site)
+ {
+ $site->Apply(-motioncommand => $X, $Y);
+ }
+ else
+ {
+ $over->Apply(-entercommand => $X, $Y, 0);
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ }
+ else
+ {
+ $site->Apply(-entercommand => $X, $Y, 1);
+ }
+ $info->{site} = $site;
+ last;
+ }
+ }
+ unless ($sflags & 1)
+ {
+ if ($over)
+ {
+ $over->Apply(-entercommand => $X, $Y, 0)
+ }
+ delete $info->{site};
+ }
+ my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
+ $t->SendClientMessage('XdndStatus',$src,32,$data);
+}
+
+sub XdndDrop
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
+ my $info = $t->{"XDND$src"};
+ my $sflags = 0;
+ my $action = 0;
+ if ($info)
+ {
+ $info->{t} = $time;
+ my $site = $info->{'site'};
+ if ($site)
+ {
+ my $X = $info->{'X'};
+ my $Y = $info->{'Y'};
+ $action = $info->{action};
+ $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types});
+ $site->Apply(-entercommand => $X, $Y, 0);
+ }
+ }
+ my ($id) = $t->wrapper;
+ my $data = pack('LLLLL',$id,$sflags,$action,0,0);
+ $t->SendClientMessage('XdndFinished',$src,32,$data);
+}
+
+sub NoteSites
+{my ($class,$t,$sites) = @_;
+ my ($wrapper) = $t->wrapper;
+ if (@$sites)
+ {
+ $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
+ $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
+ $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
+ $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
+ $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper);
+ }
+ else
+ {
+ $t->property('delete','XdndAware',$wrapper);
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DropSite.pm b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm
new file mode 100644
index 00000000000..3519c108384
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm
@@ -0,0 +1,257 @@
+package Tk::DropSite;
+require Tk::DragDrop::Common;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect);
+
+Construct Tk::Widget 'DropSite';
+
+use strict;
+use vars qw(%type @types);
+
+Tk::DragDrop->Tk::DragDrop::Common::Type('Local');
+
+my @toplevels;
+
+BEGIN
+{
+ # Are these really methods of Tk::DragDrop::Rect ?
+ no strict 'refs';
+ foreach my $name (qw(x y X Y width height widget))
+ {
+ my $key = $name;
+ *{"$key"} = sub { shift->{$key} };
+ }
+}
+
+# Dropping side API - really only here for Local drops
+# inheritance is a mess right now.
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ # No need to clear cached sites we see live data
+}
+
+sub SiteList
+{
+ # this should be inheritable - so that receive side of XDND can re-use it.
+ my ($class,$widget) = @_;
+ my $t;
+ my @list;
+ foreach $t (@toplevels)
+ {
+ my $sites = $t->{'DropSites'};
+ if ($sites)
+ {
+ $sites = $sites->{'Local'};
+ push(@list,@{$sites}) if ($sites);
+ }
+ }
+ return @list;
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $X = shift;
+ my $Y = shift;
+ $cb->Call(@_,$X - $site->X, $Y - $site->Y);
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ my $X = $event->X;
+ my $Y = $event->Y;
+ my @targ = $token->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $X, $Y, $seln,'LocalDrop',\@targ);
+ $site->Apply(-entercommand => $X, $Y, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event->X, $event->Y);
+}
+
+# This is receive side API.
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ unless (grep($_ == $t,@toplevels))
+ {
+ $Tk::DragDrop::types{'Local'} = $class if (@$sites);
+ push(@toplevels,$t);
+ $t->OnDestroy(sub { @toplevels = grep($_ != $t,@toplevels) });
+ }
+}
+
+sub UpdateDropSites
+{
+ my ($t) = @_;
+ $t->{'DropUpdate'} = 0;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $class = $type{$type};
+ $class->NoteSites($t,$sites);
+ }
+ }
+}
+
+sub QueueDropSiteUpdate
+{
+ my $obj = shift;
+ my $class = ref($obj);
+ my $t = $obj->widget->toplevel;
+ unless ($t->{'DropUpdate'})
+ {
+ $t->{'DropUpdate'} = 1;
+ $t->afterIdle(sub { UpdateDropSites($t) });
+ }
+}
+
+sub delete
+{
+ my ($obj) = @_;
+ my $w = $obj->widget;
+ $w->bindtags([grep($_ ne $obj,$w->bindtags)]);
+ my $t = $w->toplevel;
+ foreach my $type (@{$obj->{'-droptypes'}})
+ {
+ my $a = $t->{'DropSites'}->{$type};
+ @$a = grep($_ ne $obj,@$a);
+ }
+ $obj->QueueDropSiteUpdate;
+}
+
+sub DropSiteUpdate
+{
+ # Note size of widget and arrange to update properties etc.
+ my $obj = shift;
+ my $w = $obj->widget;
+ $obj->{'x'} = $w->X;
+ $obj->{'y'} = $w->Y;
+ $obj->{'X'} = $w->rootx;
+ $obj->{'Y'} = $w->rooty;
+ $obj->{'width'} = $w->Width;
+ $obj->{'height'} = $w->Height;
+ $obj->QueueDropSiteUpdate;
+}
+
+sub TopSiteUpdate
+{
+ my ($t) = @_;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $site;
+ foreach $site (@$sites)
+ {
+ $site->DropSiteUpdate;
+ }
+ }
+ }
+}
+
+sub Callback
+{
+ my $obj = shift;
+ my $key = shift;
+ my $cb = $obj->{$key};
+ $cb->Call(@_) if (defined $cb);
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ # Tk::DragDrop->Type('Local');
+}
+
+sub new
+{
+ my ($class,$w,%args) = @_;
+ my $t = $w->toplevel;
+ $args{'widget'} = $w;
+ if (exists $args{'-droptypes'})
+ {
+ # Convert single type to array-of-one
+ $args{'-droptypes'} = [$args{'-droptypes'}] unless (ref $args{'-droptypes'});
+ }
+ else
+ {
+ # Default to all known types.
+ $args{'-droptypes'} = \@types;
+ }
+ my ($key,$val);
+ while (($key,$val) = each %args)
+ {
+ if ($key =~ /command$/)
+ {
+ $val = Tk::Callback->new($val);
+ $args{$key} = $val;
+ }
+ }
+ my $obj = bless \%args,$class;
+ unless (exists $t->{'DropSites'})
+ {
+ $t->{'DropSites'} = {};
+ $t->{'DropUpdate'} = 0;
+ }
+ my $type;
+ foreach $type (@{$args{'-droptypes'}})
+ {
+ Tk::DropSite->import($type) unless (exists $type{$type});
+ my $class = $type{$type};
+ $class->InitSite($obj);
+ # Should this be indexed by type or class ?
+ unless (exists $t->{'DropSites'}->{$type})
+ {
+ $t->{'DropSites'}->{$type} = [];
+ }
+ push(@{$t->{'DropSites'}->{$type}},$obj);
+ }
+ $w->OnDestroy([$obj,'delete']);
+ $obj->DropSiteUpdate;
+ $w->bindtags([$w->bindtags,$obj]);
+ $w->Tk::bind($obj,'<Map>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Unmap>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Configure>',[$obj,'DropSiteUpdate']);
+ $t->Tk::bind($class,'<Configure>',[\&TopSiteUpdate,$t]);
+ unless (grep($_ eq $class,$t->bindtags))
+ {
+ $t->bindtags([$t->bindtags,$class]);
+ }
+ return $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm b/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm
new file mode 100644
index 00000000000..5ead808405d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DummyEncode.pm
@@ -0,0 +1,46 @@
+package Tk::DummyEncode;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ return undef unless ($name =~ /(iso8859-1|X11ControlChars)/);
+ my $pkg = $name;
+ $pkg =~ s/\W+/_/g;
+ return bless {Name => $name},$class.'::'.$pkg;
+}
+
+package Tk::DummyEncode::iso8859_1;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ $_[1] = '' if $chk;
+ return $uni;
+}
+
+sub decode
+{
+ my ($obj,$byt,$chk) = @_;
+ $_[1]
+= '' if $chk;
+ return $byt;
+}
+
+package Tk::DummyEncode::X11ControlChars;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $str = '';
+ foreach my $ch (split(//,$uni))
+ {
+ $str .= sprintf("\\x{%x}",ord($ch));
+ }
+ $_[1] = '' if $chk;
+ return $str;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/English.pm b/Master/tlpkg/tlperl/lib/Tk/English.pm
new file mode 100644
index 00000000000..de640376580
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/English.pm
@@ -0,0 +1,307 @@
+package Tk::English;
+
+require Exporter;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/English.pm#6 $
+
+use base qw(Exporter);
+
+# This file is generated automatically by pTk/makeenglish from Tk distribution.
+
+
+@EXPORT = qw(
+ &ABOVE &ACTIVATE &ACTIVE &ADD &ADDTAG &ADJUST &AFTER &ALL &ANCHOR &APPEND
+ &APPLY &ARROW1 &ARROW2 &ASCII &ASPECT &AUTO &BASELINE &BBOX &BEFORE &BELOW
+ &BEVEL &BIND &BITMAP &BLANK &BOTH &BOTTOM &BUTT &CANVASX &CANVASY &CAPTURE
+ &CASCADE &CENTER &CGET &CHAR &CHARS &CHECKBUTTON &CHILDREN &CLEAR &CLIENT
+ &CLONE &CLOSEST &COLOR &COLORMAPWINDOWS &COLUMN &COLUMNCONFIGURE &COMMAND
+ &COMPARE &CONFIGURE &COORDS &COPY &CREATE &CURRENT &CURSELECTION &DATA
+ &DCHARS &DEACTIVATE &DEBUG &DECORATIONS &DECREASING &DEFAULT &DEICONIFY
+ &DELETE &DELTA &DESELECT &DLINEINFO &DOWN &DRAGSITE &DRAGTO &DROPSITE &DTAG
+ &DUMP &ENCLOSED &END &ENTRY &ENTRYCGET &ENTRYCONFIGURE &EVAL &EXISTS &EXPAND
+ &FILL &FILLX &FILLY &FIND &FIRST &FLASH &FLAT &FOCUS &FOCUSMODEL &FOCUSNEXT
+ &FOCUSPREV &FORGET &FRACTION &FRAME &FROM &GENERATE &GEOMETRY &GEOMETRYINFO
+ &GET &GETTAGS &GRAVITY &GRAY &GRID &GROOVE &GROUP &HANDLE &HEAD &HEIGHT
+ &HIDDEN &HIDE &HORIZONTAL &ICONBITMAP &ICONIFY &ICONMASK &ICONNAME
+ &ICONPOSITION &ICONWINDOW &ICURSOR &IDENTIFY &IDLETASKS &IGNORE &IMAGE
+ &INCLUDES &INCREASING &INDEX &INFO &INSERT &INSIDE &INTEGER &INTERACTIVE
+ &INVOKE &ISMWMRUNNING &ITEM &ITEMCGET &ITEMCONFIGURE &LAST &LEFT &LINE
+ &LINECONFIGURE &LINEEND &LINES &LINESTART &LIST &LOCATION &LOWER &MARK &MAX
+ &MAXSIZE &MENUBAR &MINSIZE &MITER &MONOCHROME &MOVE &MOVETO &NAMES &NEAREST
+ &NEW &NEXT &NEXTRANGE &NONE &NORMAL &NOW &OFFSPRINGS &OUTSIDE &OVERLAPPING
+ &OVERRIDEREDIRECT &OWN &PADX &PADY &PAGECGET &PAGECONFIGURE &PAGES &PARENT
+ &PASSIVE &POSITION &POSITIONFROM &POST &POSTCASCADE &POSTSCRIPT &PRESENT
+ &PREV &PREVIOUS &PREVRANGE &PROGRAM &PROJECTING &PROPAGATE &PROTOCOL &PUT
+ &RADIOBUTTON &RAISE &RAISED &RANGE &RANGES &READ &READFILE &REAL &RECORD
+ &REDITHER &REFCOUNT &RELEASE &REMOVE &RESIZABLE &RIDGE &RIGHT &ROOT &ROUND
+ &ROW &ROWCONFIGURE &ROWS &SAVEUNDER &SCALE &SCAN &SCROLL &SEARCH &SEE
+ &SELECT &SELECTION &SEPARATOR &SET &SHOW &SIBLINGS &SIZE &SIZEFROM &SLAVES
+ &SLIDER &SOLID &SPACE &STATE &STATUS &SUNKEN &TAG &TAIL &TEAROFF &TEXT
+ &TITLE &TO &TOGGLE &TOP &TRACING &TRANSIENT &TRANSIENTFOR &TYPE &TYPES
+ &UNITS &UNPACK &UNPOST &UNSET &UP &USER &VARIABLE &VERTICAL &VISIBILITY
+ &WIDTH &WINDOW &WITHDRAW &WITHTAG &WORDEND &WORDSTART &WRITE &XVIEW
+ &YPOSITION &YVIEW
+);
+sub ABOVE () { 'above' }
+sub ACTIVATE () { 'activate' }
+sub ACTIVE () { 'active' }
+sub ADD () { 'add' }
+sub ADDTAG () { 'addtag' }
+sub ADJUST () { 'adjust' }
+sub AFTER () { 'after' }
+sub ALL () { 'all' }
+sub ANCHOR () { 'anchor' }
+sub APPEND () { 'append' }
+sub APPLY () { 'apply' }
+sub ARROW1 () { 'arrow1' }
+sub ARROW2 () { 'arrow2' }
+sub ASCII () { 'ascii' }
+sub ASPECT () { 'aspect' }
+sub AUTO () { 'auto' }
+sub BASELINE () { 'baseline' }
+sub BBOX () { 'bbox' }
+sub BEFORE () { 'before' }
+sub BELOW () { 'below' }
+sub BEVEL () { 'bevel' }
+sub BIND () { 'bind' }
+sub BITMAP () { 'bitmap' }
+sub BLANK () { 'blank' }
+sub BOTH () { 'both' }
+sub BOTTOM () { 'bottom' }
+sub BUTT () { 'butt' }
+sub CANVASX () { 'canvasx' }
+sub CANVASY () { 'canvasy' }
+sub CAPTURE () { 'capture' }
+sub CASCADE () { 'cascade' }
+sub CENTER () { 'center' }
+sub CGET () { 'cget' }
+sub CHAR () { 'char' }
+sub CHARS () { 'chars' }
+sub CHECKBUTTON () { 'checkbutton' }
+sub CHILDREN () { 'children' }
+sub CLEAR () { 'clear' }
+sub CLIENT () { 'client' }
+sub CLONE () { 'clone' }
+sub CLOSEST () { 'closest' }
+sub COLOR () { 'color' }
+sub COLORMAPWINDOWS () { 'colormapwindows' }
+sub COLUMN () { 'column' }
+sub COLUMNCONFIGURE () { 'columnconfigure' }
+sub COMMAND () { 'command' }
+sub COMPARE () { 'compare' }
+sub CONFIGURE () { 'configure' }
+sub COORDS () { 'coords' }
+sub COPY () { 'copy' }
+sub CREATE () { 'create' }
+sub CURRENT () { 'current' }
+sub CURSELECTION () { 'curselection' }
+sub DATA () { 'data' }
+sub DCHARS () { 'dchars' }
+sub DEACTIVATE () { 'deactivate' }
+sub DEBUG () { 'debug' }
+sub DECORATIONS () { 'decorations' }
+sub DECREASING () { 'decreasing' }
+sub DEFAULT () { 'default' }
+sub DEICONIFY () { 'deiconify' }
+sub DELETE () { 'delete' }
+sub DELTA () { 'delta' }
+sub DESELECT () { 'deselect' }
+sub DLINEINFO () { 'dlineinfo' }
+sub DOWN () { 'down' }
+sub DRAGSITE () { 'dragsite' }
+sub DRAGTO () { 'dragto' }
+sub DROPSITE () { 'dropsite' }
+sub DTAG () { 'dtag' }
+sub DUMP () { 'dump' }
+sub ENCLOSED () { 'enclosed' }
+sub END () { 'end' }
+sub ENTRY () { 'entry' }
+sub ENTRYCGET () { 'entrycget' }
+sub ENTRYCONFIGURE () { 'entryconfigure' }
+sub EVAL () { 'eval' }
+sub EXISTS () { 'exists' }
+sub EXPAND () { 'expand' }
+sub FILL () { 'fill' }
+sub FILLX () { 'fillx' }
+sub FILLY () { 'filly' }
+sub FIND () { 'find' }
+sub FIRST () { 'first' }
+sub FLASH () { 'flash' }
+sub FLAT () { 'flat' }
+sub FOCUS () { 'focus' }
+sub FOCUSMODEL () { 'focusmodel' }
+sub FOCUSNEXT () { 'focusnext' }
+sub FOCUSPREV () { 'focusprev' }
+sub FORGET () { 'forget' }
+sub FRACTION () { 'fraction' }
+sub FRAME () { 'frame' }
+sub FROM () { 'from' }
+sub GENERATE () { 'generate' }
+sub GEOMETRY () { 'geometry' }
+sub GEOMETRYINFO () { 'geometryinfo' }
+sub GET () { 'get' }
+sub GETTAGS () { 'gettags' }
+sub GRAVITY () { 'gravity' }
+sub GRAY () { 'gray' }
+sub GRID () { 'grid' }
+sub GROOVE () { 'groove' }
+sub GROUP () { 'group' }
+sub HANDLE () { 'handle' }
+sub HEAD () { 'head' }
+sub HEIGHT () { 'height' }
+sub HIDDEN () { 'hidden' }
+sub HIDE () { 'hide' }
+sub HORIZONTAL () { 'horizontal' }
+sub ICONBITMAP () { 'iconbitmap' }
+sub ICONIFY () { 'iconify' }
+sub ICONMASK () { 'iconmask' }
+sub ICONNAME () { 'iconname' }
+sub ICONPOSITION () { 'iconposition' }
+sub ICONWINDOW () { 'iconwindow' }
+sub ICURSOR () { 'icursor' }
+sub IDENTIFY () { 'identify' }
+sub IDLETASKS () { 'idletasks' }
+sub IGNORE () { 'ignore' }
+sub IMAGE () { 'image' }
+sub INCLUDES () { 'includes' }
+sub INCREASING () { 'increasing' }
+sub INDEX () { 'index' }
+sub INFO () { 'info' }
+sub INSERT () { 'insert' }
+sub INSIDE () { 'inside' }
+sub INTEGER () { 'integer' }
+sub INTERACTIVE () { 'interactive' }
+sub INVOKE () { 'invoke' }
+sub ISMWMRUNNING () { 'ismwmrunning' }
+sub ITEM () { 'item' }
+sub ITEMCGET () { 'itemcget' }
+sub ITEMCONFIGURE () { 'itemconfigure' }
+sub LAST () { 'last' }
+sub LEFT () { 'left' }
+sub LINE () { 'line' }
+sub LINECONFIGURE () { 'lineconfigure' }
+sub LINEEND () { 'lineend' }
+sub LINES () { 'lines' }
+sub LINESTART () { 'linestart' }
+sub LIST () { 'list' }
+sub LOCATION () { 'location' }
+sub LOWER () { 'lower' }
+sub MARK () { 'mark' }
+sub MAX () { 'max' }
+sub MAXSIZE () { 'maxsize' }
+sub MENUBAR () { 'menubar' }
+sub MINSIZE () { 'minsize' }
+sub MITER () { 'miter' }
+sub MONOCHROME () { 'monochrome' }
+sub MOVE () { 'move' }
+sub MOVETO () { 'moveto' }
+sub NAMES () { 'names' }
+sub NEAREST () { 'nearest' }
+sub NEW () { 'new' }
+sub NEXT () { 'next' }
+sub NEXTRANGE () { 'nextrange' }
+sub NONE () { 'none' }
+sub NORMAL () { 'normal' }
+sub NOW () { 'now' }
+sub OFFSPRINGS () { 'offsprings' }
+sub OUTSIDE () { 'outside' }
+sub OVERLAPPING () { 'overlapping' }
+sub OVERRIDEREDIRECT () { 'overrideredirect' }
+sub OWN () { 'own' }
+sub PADX () { 'padx' }
+sub PADY () { 'pady' }
+sub PAGECGET () { 'pagecget' }
+sub PAGECONFIGURE () { 'pageconfigure' }
+sub PAGES () { 'pages' }
+sub PARENT () { 'parent' }
+sub PASSIVE () { 'passive' }
+sub POSITION () { 'position' }
+sub POSITIONFROM () { 'positionfrom' }
+sub POST () { 'post' }
+sub POSTCASCADE () { 'postcascade' }
+sub POSTSCRIPT () { 'postscript' }
+sub PRESENT () { 'present' }
+sub PREV () { 'prev' }
+sub PREVIOUS () { 'previous' }
+sub PREVRANGE () { 'prevrange' }
+sub PROGRAM () { 'program' }
+sub PROJECTING () { 'projecting' }
+sub PROPAGATE () { 'propagate' }
+sub PROTOCOL () { 'protocol' }
+sub PUT () { 'put' }
+sub RADIOBUTTON () { 'radiobutton' }
+sub RAISE () { 'raise' }
+sub RAISED () { 'raised' }
+sub RANGE () { 'range' }
+sub RANGES () { 'ranges' }
+sub READ () { 'read' }
+sub READFILE () { 'readfile' }
+sub REAL () { 'real' }
+sub RECORD () { 'record' }
+sub REDITHER () { 'redither' }
+sub REFCOUNT () { 'refcount' }
+sub RELEASE () { 'release' }
+sub REMOVE () { 'remove' }
+sub RESIZABLE () { 'resizable' }
+sub RIDGE () { 'ridge' }
+sub RIGHT () { 'right' }
+sub ROOT () { 'root' }
+sub ROUND () { 'round' }
+sub ROW () { 'row' }
+sub ROWCONFIGURE () { 'rowconfigure' }
+sub ROWS () { 'rows' }
+sub SCALE () { 'scale' }
+sub SCAN () { 'scan' }
+sub SCROLL () { 'scroll' }
+sub SEARCH () { 'search' }
+sub SEE () { 'see' }
+sub SELECT () { 'select' }
+sub SELECTION () { 'selection' }
+sub SEPARATOR () { 'separator' }
+sub SET () { 'set' }
+sub SHOW () { 'show' }
+sub SIBLINGS () { 'siblings' }
+sub SIZE () { 'size' }
+sub SIZEFROM () { 'sizefrom' }
+sub SLAVES () { 'slaves' }
+sub SLIDER () { 'slider' }
+sub SOLID () { 'solid' }
+sub SPACE () { 'space' }
+sub STATE () { 'state' }
+sub STATUS () { 'status' }
+sub SUNKEN () { 'sunken' }
+sub TAG () { 'tag' }
+sub TAIL () { 'tail' }
+sub TEAROFF () { 'tearoff' }
+sub TEXT () { 'text' }
+sub TITLE () { 'title' }
+sub TO () { 'to' }
+sub TOGGLE () { 'toggle' }
+sub TOP () { 'top' }
+sub TRACING () { 'tracing' }
+sub TRANSIENT () { 'transient' }
+sub TRANSIENTFOR () { 'transientfor' }
+sub TYPE () { 'type' }
+sub TYPES () { 'types' }
+sub UNITS () { 'units' }
+sub UNPACK () { 'unpack' }
+sub UNPOST () { 'unpost' }
+sub UNSET () { 'unset' }
+sub UP () { 'up' }
+sub USER () { 'user' }
+sub VARIABLE () { 'variable' }
+sub VERTICAL () { 'vertical' }
+sub VISIBILITY () { 'visibility' }
+sub WIDTH () { 'width' }
+sub WINDOW () { 'window' }
+sub WITHDRAW () { 'withdraw' }
+sub WITHTAG () { 'withtag' }
+sub WORDEND () { 'wordend' }
+sub WORDSTART () { 'wordstart' }
+sub WRITE () { 'write' }
+sub XVIEW () { 'xview' }
+sub YPOSITION () { 'yposition' }
+sub YVIEW () { 'yview' }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Entry.pm b/Master/tlpkg/tlperl/lib/Tk/Entry.pm
new file mode 100644
index 00000000000..51b3f0c6767
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Entry.pm
@@ -0,0 +1,615 @@
+package Tk::Entry;
+
+# Converted from entry.tcl --
+#
+# This file defines the default bindings for Tk entry widgets.
+#
+# @(#) entry.tcl 1.22 94/12/17 16:05:14
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+use strict;
+$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/;
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use Tk::Widget ();
+use Tk::Clipboard ();
+use base qw(Tk::Clipboard Tk::Widget);
+
+import Tk qw(Ev $XS_VERSION);
+
+Construct Tk::Widget 'Entry';
+
+bootstrap Tk::Entry;
+
+sub Tk_cmd { \&Tk::entry }
+
+Tk::Methods('bbox','delete','get','icursor','index','insert','scan',
+ 'selection','validate','xview');
+
+use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)],
+ 'xview' => [qw(moveto scroll)],
+ );
+
+sub wordstart
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ $pos = $w->index('insert')-1 unless(defined $pos);
+ $string = substr($string,0,$pos);
+ $string =~ s/\S*$//;
+ length $string;
+}
+
+sub wordend
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ my $anc = length $string;
+ $pos = $w->index('insert') unless(defined $pos);
+ $string = substr($string,$pos);
+ $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x;
+ $anc - length($string);
+}
+
+sub deltainsert
+{
+ my ($w,$d) = @_;
+ return $w->index('insert')+$d;
+}
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters an
+# entry widget or an entry widget receives the input focus. It creates
+# all of the class bindings for entries.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard
+ $mw->bind($class,'<<Clear>>' => sub {
+ my $w = shift;
+ $w->delete("sel.first", "sel.last");
+ });
+ $mw->bind($class,'<<PasteSelection>>' => [sub {
+ my($w, $x) = @_;
+ # XXX logic in Tcl/Tk version screwed up?
+ if (!$Tk::strictMotif && !$Tk::mouseMoved) {
+ $w->Paste($x);
+ }
+ }, Ev('x')]);
+
+ # Standard Motif bindings:
+ # The <Escape> binding is different from the Tcl/Tk version:
+ $mw->bind($class,'<Escape>','selectionClear');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']);
+ $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']);
+ $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]);
+ $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']);
+
+ $mw->bind($class,'<Shift-1>','Shift_1');
+
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Control-1>','Control_1');
+ $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]);
+ $mw->bind($class,'<Home>',['SetCursor',0]);
+ $mw->bind($class,'<Shift-Home>',['KeySelect',0]);
+ $mw->bind($class,'<End>',['SetCursor','end']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','end']);
+ $mw->bind($class,'<Delete>','Delete');
+
+ $mw->bind($class,'<BackSpace>','Backspace');
+
+ $mw->bind($class,'<Control-space>',['selectionFrom','insert']);
+ $mw->bind($class,'<Select>',['selectionFrom','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']);
+ $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']);
+
+ $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']);
+ $mw->bind($class,'<Control-backslash>','selectionClear');
+
+ # $class->clipboardOperations($mw,qw[Copy Cut Paste]);
+
+ $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]);
+
+ # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
+ # Otherwise, if a widget binding for one of these is defined, the
+ # <KeyPress> class binding will also fire and insert the character,
+ # which is wrong. Ditto for Return, and Tab.
+
+ $mw->bind($class,'<Alt-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Meta-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Control-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Return>' ,'NoOp');
+ $mw->bind($class,'<KP_Enter>' ,'NoOp');
+ $mw->bind($class,'<Tab>' ,'NoOp');
+ if ($mw->windowingsystem =~ /^(?:classic|aqua)$/)
+ {
+ $mw->bind($class,'<Command-KeyPress>', 'NoOp');
+ }
+
+ # On Windows, paste is done using Shift-Insert. Shift-Insert already
+ # generates the <<Paste>> event, so we don't need to do anything here.
+ if ($Tk::platform ne 'MSWin32')
+ {
+ $mw->bind($class,'<Insert>','InsertSelection');
+ }
+
+ if (!$Tk::strictMotif)
+ {
+ # Additional emacs-like bindings:
+ $mw->bind($class,'<Control-a>',['SetCursor',0]);
+ $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Control-d>',['delete','insert']);
+ $mw->bind($class,'<Control-e>',['SetCursor','end']);
+ $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-h>','Backspace');
+ $mw->bind($class,'<Control-k>',['delete','insert','end']);
+
+ $mw->bind($class,'<Control-t>','Transpose');
+
+ # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead
+ $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']);
+
+ # A few additional bindings from John Ousterhout.
+# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<2>','Button_2');
+ $mw->bind($class,'<B2-Motion>','B2_Motion');
+# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2');
+ }
+ return $class;
+}
+
+
+sub Shift_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::selectMode = 'char';
+ $w->selectionAdjust('@' . $Ev->x)
+}
+
+
+sub Control_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->icursor('@' . $Ev->x)
+}
+
+
+sub Delete
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ $w->delete('insert')
+ }
+}
+
+
+sub InsertSelection
+{
+ my $w = shift;
+ eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)}
+}
+
+
+# Original is ::tk::EntryScanMark
+sub Button_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->scan('mark',$Ev->x);
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::mouseMoved = 0
+}
+
+
+# Original is ::tk::EntryScanDrag
+sub B2_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ # Make sure these exist, as some weird situations can trigger the
+ # motion binding without the initial press. [Tcl/Tk Bug #220269]
+ if (!defined $Tk::x) { $Tk::x = $Ev->x }
+ if (abs(($Ev->x-$Tk::x)) > 2)
+ {
+ $Tk::mouseMoved = 1
+ }
+ $w->scan('dragto',$Ev->x)
+}
+
+
+# XXX Not needed anymore
+sub ButtonRelease_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ eval
+ {local $SIG{__DIE__};
+ $w->insert('insert',$w->SelectionGet);
+ $w->SeeInsert;
+ }
+ }
+}
+
+sub Button1Release
+{
+ shift->CancelRepeat;
+}
+
+# ::tk::EntryClosestGap --
+# Given x and y coordinates, this procedure finds the closest boundary
+# between characters to the given coordinates and returns the index
+# of the character just after the boundary.
+#
+# Arguments:
+# w - The entry window.
+# x - X-coordinate within the window.
+sub ClosestGap
+{
+ my($w, $x) = @_;
+ my $pos = $w->index('@'.$x);
+ my @bbox = $w->bbox($pos);
+ if ($x - $bbox[0] < $bbox[2] / 2)
+ {
+ return $pos;
+ }
+ $pos + 1;
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in entry
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the button press.
+sub Button1
+{
+ my $w = shift;
+ my $x = shift;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $Tk::pressX = $x;
+ $w->icursor($w->ClosestGap($x));
+ $w->selectionFrom('insert');
+ $w->selectionClear;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->focus()
+ }
+}
+
+sub Motion
+{
+ my ($w,$x,$y) = @_;
+ $Tk::x = $x; # XXX ?
+ $w->MouseSelect($x);
+}
+
+# MouseSelect --
+# This procedure is invoked when dragging out a selection with
+# the mouse. Depending on the selection mode (character, word,
+# line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the mouse.
+sub MouseSelect
+{
+
+ my $w = shift;
+ my $x = shift;
+ return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry';
+ $Tk::selectMode = shift if (@_);
+ my $cur = $w->index($w->ClosestGap($x));
+ return unless defined $cur;
+ my $anchor = $w->index('anchor');
+ return unless defined $anchor;
+ $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"?
+ if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
+ {
+ $Tk::mouseMoved = 1
+ }
+ my $mode = $Tk::selectMode;
+ return unless $mode;
+ if ($mode eq 'char')
+ {
+ # The Tcl version uses selectionRange here XXX
+ if ($Tk::mouseMoved)
+ {
+ if ($cur < $anchor)
+ {
+ $w->selectionTo($cur)
+ }
+ else
+ {
+ $w->selectionTo($cur+1)
+ }
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ # The Tcl version uses tcl_wordBreakBefore/After here XXX
+ if ($cur < $w->index('anchor'))
+ {
+ $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1))
+ }
+ else
+ {
+ $w->selectionRange($w->wordstart($anchor),$w->wordend($cur))
+ }
+ }
+ elsif ($mode eq 'line')
+ {
+ $w->selectionRange(0,'end')
+ }
+ if (@_)
+ {
+ my $ipos = shift;
+ eval {local $SIG{__DIE__}; $w->icursor($ipos) };
+ }
+ $w->idletasks;
+}
+# ::tk::EntryPaste --
+# This procedure sets the insertion cursor to the current mouse position,
+# pastes the selection there, and sets the focus to the window.
+#
+# Arguments:
+# w - The entry window.
+# x - X position of the mouse.
+sub Paste
+{
+ my($w, $x) = @_;
+ $w->icursor($w->ClosestGap($x));
+ eval { local $SIG{__DIE__};
+ $w->insert("insert", $w->GetSelection);
+ $w->SeeInsert; # Perl/Tk extension
+ };
+ if ($w->cget(-state) ne 'disabled')
+ {
+ $w->focus;
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window left or right,
+# depending on where the mouse is, and reschedules itself as an
+# 'after' command so that the window continues to scroll until the
+# mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ my $x = shift;
+ return if !Tk::Exists($w);
+ if ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->MouseSelect($x);
+ $w->RepeatId($w->after(50,['AutoScan',$w,$x]))
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The entry window.
+# new - A new position for the insertion cursor (the cursor hasn't
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my $w = shift;
+ my $new = shift;
+ if (!$w->selectionPresent)
+ {
+ $w->selectionFrom('insert');
+ $w->selectionTo($new)
+ }
+ else
+ {
+ $w->selectionAdjust($new)
+ }
+ $w->icursor($new);
+ $w->SeeInsert;
+}
+# Insert --
+# Insert a string into an entry at the point of the insertion cursor.
+# If there is a selection in the entry, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The entry window in which to insert the string
+# s - The string to insert (usually just a single character)
+sub Insert
+{
+ my $w = shift;
+ my $s = shift;
+ return unless (defined $s && $s ne '');
+ eval
+ {local $SIG{__DIE__};
+ my $insert = $w->index('insert');
+ if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert)
+ {
+ $w->deleteSelected
+ }
+ };
+ $w->insert('insert',$s);
+ $w->SeeInsert
+}
+# Backspace --
+# Backspace over the character just before the insertion cursor.
+#
+# Arguments:
+# w - The entry window in which to backspace.
+sub Backspace
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ my $x = $w->index('insert')-1;
+ $w->delete($x) if ($x >= 0);
+ # XXX Missing repositioning part from Tcl/Tk source
+ }
+}
+# SeeInsert
+# Make sure that the insertion cursor is visible in the entry window.
+# If not, adjust the view so that it is.
+#
+# Arguments:
+# w - The entry window.
+sub SeeInsert
+{
+ my $w = shift;
+ my $c = $w->index('insert');
+#
+# Probably a bug in your version of tcl/tk (I've not this problem
+# when I test Entry in the widget demo for tcl/tk)
+# index('\@0') give always 0. Consequence :
+# if you make <Control-E> or <Control-F> view is adapted
+# but with <Control-A> or <Control-B> view is not adapted
+#
+ my $left = $w->index('@0');
+ if ($left > $c)
+ {
+ $w->xview($c);
+ return;
+ }
+ my $x = $w->width;
+ while ($w->index('@' . $x) <= $c && $left < $c)
+ {
+ $left += 1;
+ $w->xview($left)
+ }
+}
+# SetCursor
+# Move the insertion cursor to a given position in an entry. Also
+# clears the selection, if there is one in the entry, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The entry window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my $w = shift;
+ my $pos = shift;
+ $w->icursor($pos);
+ $w->selectionClear;
+ $w->SeeInsert;
+}
+# Transpose
+# This procedure implements the 'transpose' function for entry widgets.
+# It tranposes the characters on either side of the insertion cursor,
+# unless the cursor is at the end of the line. In this case it
+# transposes the two characters to the left of the cursor. In either
+# case, the cursor ends up to the right of the transposed characters.
+#
+# Arguments:
+# w - The entry window.
+sub Transpose
+{
+ my $w = shift;
+ my $i = $w->index('insert');
+ $i++ if ($i < $w->index('end'));
+ my $first = $i-2;
+ return if ($first < 0);
+ my $str = $w->get;
+ my $new = substr($str,$i-1,1) . substr($str,$first,1);
+ $w->delete($first,$i);
+ $w->insert('insert',$new);
+ $w->SeeInsert;
+}
+
+sub tabFocus
+{
+ my $w = shift;
+ $w->selectionRange(0,'end');
+ $w->icursor('end');
+ $w->SUPER::tabFocus;
+}
+
+# ::tk::EntryGetSelection --
+#
+# Returns the selected text of the entry with respect to the -show option.
+#
+# Arguments:
+# w - The entry window from which the text to get
+sub getSelected
+{
+ my $w = shift;
+ return undef unless $w->selectionPresent;
+ my $str = $w->get;
+ my $show = $w->cget('-show');
+ $str = $show x length($str) if (defined $show);
+ my $s = $w->index('sel.first');
+ my $e = $w->index('sel.last');
+ return substr($str,$s,$e-$s);
+}
+
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm
new file mode 100644
index 00000000000..19377eaeca4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ErrorDialog.pm
@@ -0,0 +1,125 @@
+package Tk::ErrorDialog;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Tk ();
+require Tk::Dialog;
+use base qw(Tk::Toplevel);
+
+
+# ErrorDialog - a translation of bgerror() from Tcl/Tk to Perl/Tk.
+#
+# Currently TkPerl background errors are sent to stdout/stderr; use this
+# module if you want them in a window. You can also "roll your own" by
+# supplying the routine Tk::Error.
+
+use strict;
+
+Construct Tk::Widget 'ErrorDialog';
+
+my %options = ( -buttons => ['OK', 'Skip Messages', 'Stack trace'],
+ -bitmap => 'error'
+ );
+my $ED_OBJECT;
+
+sub import
+{
+ my $class = shift;
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $options{$key} = $val;
+ }
+}
+
+sub Populate {
+
+ # ErrorDialog constructor. Uses `new' method from base class
+ # to create object container then creates the dialog toplevel and the
+ # traceback toplevel.
+
+ my($cw, $args) = @_;
+
+ my $dr = $cw->Dialog(
+ -title => 'Error in '.$cw->MainWindow->name,
+ -text => 'on-the-fly-text',
+ -bitmap => $options{'-bitmap'},
+ -buttons => $options{'-buttons'},
+ );
+ $cw->minsize(1, 1);
+ $cw->title('Stack Trace for Error');
+ $cw->iconname('Stack Trace');
+ my $t_ok = $cw->Button(
+ -text => 'OK',
+ -command => [
+ sub {
+ shift->withdraw;
+ }, $cw,
+ ]
+ );
+ my $t_text = $cw->Text(
+ -relief => 'sunken',
+ -bd => 2,
+ -setgrid => 'true',
+ -width => 60,
+ -height => 20,
+ );
+ my $t_scroll = $cw->Scrollbar(
+ -relief => 'sunken',
+ -command => ['yview', $t_text],
+ );
+ $t_text->configure(-yscrollcommand => ['set', $t_scroll]);
+ $t_ok->pack(-side => 'bottom', -padx => '3m', -pady => '2m');
+ $t_scroll->pack(-side => 'right', -fill => 'y');
+ $t_text->pack(-side => 'left', -expand => 'yes', -fill => 'both');
+ $cw->withdraw;
+
+ $cw->Advertise(error_dialog => $dr); # advertise dialog widget
+ $cw->Advertise(text => $t_text); # advertise text widget
+ $cw->ConfigSpecs(-cleanupcode => [PASSIVE => undef, undef, undef],
+ -appendtraceback => [ PASSIVE => undef, undef, 1 ]);
+ $ED_OBJECT = $cw;
+ $cw->protocol('WM_DELETE_WINDOW' => sub {$cw->withdraw});
+ return $cw;
+
+} # end Populate
+
+sub Tk::Error {
+
+ # Post a dialog box with the error message and give the user a chance
+ # to see a more detailed stack trace.
+
+ my($w, $error, @msgs) = @_;
+
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+
+ $w->ErrorDialog if not defined $ED_OBJECT;
+
+ my($d, $t) = ($ED_OBJECT->Subwidget('error_dialog'), $ED_OBJECT->Subwidget('text'));
+# chop $error;
+ $d->configure(-text => "Error: $error");
+ $d->bell;
+ my $ans = $d->Show;
+
+ $t->delete('0.0', 'end') if not $ED_OBJECT->{'-appendtraceback'};
+ $t->insert('end', "\n");
+ $t->mark('set', 'ltb', 'end');
+ $t->insert('end', "--- Begin Traceback ---\n$error\n");
+ my $msg;
+ for $msg (@msgs) {
+ $t->insert('end', "$msg\n");
+ }
+ $t->yview('ltb');
+
+ $ED_OBJECT->deiconify if ($ans =~ /trace/i);
+
+ my $c = $ED_OBJECT->{Configure}{'-cleanupcode'};
+ &$c if defined $c; # execute any cleanup code if it was defined
+ $w->break if ($ans =~ /skip/i);
+
+} # end Tk::Error
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Event.pm b/Master/tlpkg/tlperl/lib/Tk/Event.pm
new file mode 100644
index 00000000000..cecd57c54ae
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Event.pm
@@ -0,0 +1,13 @@
+package Tk::Event;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK);
+END { CleanupGlue() }
+$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+$XS_VERSION = '804.027';
+use base qw(Exporter);
+use XSLoader;
+@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
+XSLoader::load 'Tk::Event',$XS_VERSION;
+require Tk::Event::IO;
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm
new file mode 100644
index 00000000000..10b47e246ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm
@@ -0,0 +1,132 @@
+package Tk::Event::IO;
+use strict;
+use Carp;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+use Symbol ();
+
+@EXPORT_OK = qw(READABLE WRITABLE);
+
+sub PrintArgs
+{
+ my $func = (caller(1))[3];
+ print "$func(",join(',',@_),")\n";
+}
+
+sub PRINT
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return print $h @_;
+}
+
+sub PRINTF
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return printf $h @_;
+}
+
+sub WRITE
+{
+ my $obj = $_[0];
+ $obj->wait(WRITABLE);
+ return syswrite($obj->handle,$_[1],$_[2]);
+}
+
+my $depth = 0;
+sub READLINE
+{
+ my $obj = shift;
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ my $w = <$h>;
+ return $w;
+}
+
+sub READ
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
+}
+
+sub GETC
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return getc($h);
+}
+
+sub CLOSE
+{
+ my $obj = shift;
+ $obj->unwatch;
+ my $h = $obj->handle;
+ return close($h);
+}
+
+sub EOF
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return eof($h);
+}
+
+sub FILENO
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return fileno($h);
+}
+
+sub imode
+{
+ my $mode = shift;
+ my $imode = ${{'readable' => READABLE(),
+ 'writable' => WRITABLE()}}{$mode};
+ croak("Invalid handler type '$mode'") unless (defined $imode);
+ return $imode;
+}
+
+sub fileevent
+{
+ my ($widget,$file,$mode,$cb) = @_;
+ my $imode = imode($mode);
+ unless (ref $file)
+ {
+ no strict 'refs';
+ $file = Symbol::qualify($file,(caller)[0]);
+ $file = \*{$file};
+ }
+ my $obj = tied(*$file);
+ unless ($obj && $obj->isa('Tk::Event::IO'))
+ {
+ $obj = tie *$file,'Tk::Event::IO', $file;
+ }
+ if (@_ == 3)
+ {
+ # query return the handler
+ return $obj->handler($imode);
+ }
+ else
+ {
+ # set the handler
+ my $h = $obj->handler($imode,$cb);
+ undef $obj; # Prevent warnings about untie with ref to object
+ unless ($h)
+ {
+ untie *$file;
+ }
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/FBox.pm b/Master/tlpkg/tlperl/lib/Tk/FBox.pm
new file mode 100644
index 00000000000..fed7501aea4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/FBox.pm
@@ -0,0 +1,1043 @@
+# -*- perl -*-
+#
+# tkfbox.tcl --
+#
+# Implements the "TK" standard file selection dialog box. This
+# dialog box is used on the Unix platforms whenever the tk_strictMotif
+# flag is not set.
+#
+# The "TK" standard file selection dialog box is similar to the
+# file selection dialog box on Win95(TM). The user can navigate
+# the directories by clicking on the folder icons or by
+# selecting the "Directory" option menu. The user can select
+# files by clicking on the file icons or by entering a filename
+# in the "Filename:" entry.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Translated to perl/Tk by Slaven Rezic <slaven@rezic.de>.
+#
+
+#----------------------------------------------------------------------
+#
+# F I L E D I A L O G
+#
+#----------------------------------------------------------------------
+# tkFDialog --
+#
+# Implements the TK file selection dialog. This dialog is used when
+# the tk_strictMotif flag is set to false. This procedure shouldn't
+# be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
+#
+
+package Tk::FBox;
+require Tk::Toplevel;
+
+use strict;
+use vars qw($VERSION $updirImage $folderImage $fileImage);
+
+$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Toplevel);
+
+Construct Tk::Widget 'FBox';
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ if ($Tk::VERSION < 804) {
+ *FDialog = \&Tk::FBox::FDialog;
+ *MotifFDialog = \&Tk::FBox::FDialog;
+ } else {
+ *tk_getOpenFile = sub {
+ Tk::FBox::FDialog("tk_getOpenFile", @_);
+ };
+ *tk_getSaveFile = sub {
+ Tk::FBox::FDialog("tk_getSaveFile", @_);
+ };
+ }
+ }
+}
+
+# Note that -sortcmd is experimental and the interface is likely to change.
+# Using -sortcmd is really strange :-(
+# $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a});
+# or, un-perlish, but useable (now activated in code):
+# $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]});
+
+sub Populate {
+ my($w, $args) = @_;
+
+ require Tk::IconList;
+ require File::Basename;
+ require Cwd;
+
+ $w->SUPER::Populate($args);
+
+ # f1: the frame with the directory option menu
+ my $f1 = $w->Frame;
+ my $lab = $f1->Label(-text => 'Directory:', -underline => 0);
+ $w->{'dirMenu'} = my $dirMenu =
+ $f1->Optionmenu(-variable => \$w->{'selectPath'},
+ -textvariable => \$w->{'selectPath'},
+ -command => ['SetPath', $w]);
+ my $upBtn = $f1->Button;
+ if (!defined $updirImage->{$w->MainWindow}) {
+ $updirImage->{$w->MainWindow} = $w->Bitmap(-data => <<EOF);
+#define updir_width 28
+#define updir_height 16
+static char updir_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
+ 0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
+ 0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
+ 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
+ 0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
+ 0xf0, 0xff, 0xff, 0x01};
+EOF
+ }
+ $upBtn->configure(-image => $updirImage->{$w->MainWindow});
+ $dirMenu->configure(-takefocus => 1, -highlightthickness => 2);
+ $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both');
+ $lab->pack(-side => 'left', -padx => 4, -fill => 'both');
+ $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4);
+
+ $w->{'icons'} = my $icons =
+ $w->IconList(-command => ['OkCmd', $w, 'iconlist'],
+ );
+ $icons->bind('<<ListboxSelect>>' => [$w, 'ListBrowse']);
+
+ # f2: the frame with the OK button and the "file name" field
+ my $f2 = $w->Frame(-bd => 0);
+#XXX File name => File names if multiple
+ my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e',
+ -width => 14, -underline => 5, -pady => 0);
+ $w->{'ent'} = my $ent = $f2->Entry;
+
+ # The font to use for the icons. The default Canvas font on Unix
+ # is just deviant.
+# $w->{'icons'}{'font'} = $ent->cget(-font);
+ $w->{'icons'}->configure(-font => $ent->cget(-font));
+
+ # f3: the frame with the cancel button and the file types field
+ my $f3 = $w->Frame(-bd => 0);
+
+ # The "File of types:" label needs to be grayed-out when
+ # -filetypes are not specified. The label widget does not support
+ # grayed-out text on monochrome displays. Therefore, we have to
+ # use a button widget to emulate a label widget (by setting its
+ # bindtags)
+ $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button
+ (-text => 'Files of type:',
+ -anchor => 'e',
+ -width => 14,
+ -underline => 9,
+ -bd => $f2_lab->cget(-bd),
+ -highlightthickness => $f2_lab->cget(-highlightthickness),
+ -relief => $f2_lab->cget(-relief),
+ -padx => $f2_lab->cget(-padx),
+ -pady => $f2_lab->cget(-pady),
+ -takefocus => 0,
+ );
+ $typeMenuLab->bindtags([$typeMenuLab, 'Label',
+ $typeMenuLab->toplevel, 'all']);
+ $w->{'typeMenuBtn'} = my $typeMenuBtn =
+ $f3->Menubutton(-indicatoron => 1, -tearoff => 0);
+ $typeMenuBtn->configure(-takefocus => 1,
+ -highlightthickness => 2,
+ -relief => 'raised',
+ -bd => 2,
+ -anchor => 'w',
+ );
+
+ # the okBtn is created after the typeMenu so that the keyboard traversal
+ # is in the right order
+ $w->{'okBtn'} = my $okBtn = $f2->Button
+ (-text => 'OK',
+ -underline => 0,
+ -width => 6,
+ -default => 'active',
+ -pady => 3,
+ );
+ my $cancelBtn = $f3->Button
+ (-text => 'Cancel',
+ -underline => 0,
+ -width => 6,
+ -default => 'normal',
+ -pady => 3,
+ );
+
+ # pack the widgets in f2 and f3
+ $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e');
+ $f2_lab->pack(-side => 'left', -padx => 4);
+ $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0);
+ $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w');
+ $typeMenuLab->pack(-side => 'left', -padx => 4);
+ $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right');
+
+ # Pack all the frames together. We are done with widget construction.
+ $f1->pack(-side => 'top', -fill => 'x', -pady => 4);
+ $f3->pack(-side => 'bottom', -fill => 'x');
+ $f2->pack(-side => 'bottom', -fill => 'x');
+ $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1);
+
+ # Set up the event handlers
+ $ent->bind('<Return>',[$w,'ActivateEnt']);
+ $upBtn->configure(-command => ['UpDirCmd', $w]);
+ $okBtn->configure(-command => ['OkCmd', $w]);
+ $cancelBtn->configure(-command, ['CancelCmd', $w]);
+
+ $w->bind('<Alt-d>',[$dirMenu,'focus']);
+ $w->bind('<Alt-t>',sub {
+ if ($typeMenuBtn->cget(-state) eq 'normal') {
+ $typeMenuBtn->focus;
+ } });
+ $w->bind('<Alt-n>',[$ent,'focus']);
+ $w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']);
+ $w->bind('<Alt-c>',[$cancelBtn,'invoke']);
+ $w->bind('<Alt-o>',['InvokeBtn','Open']);
+ $w->bind('<Alt-s>',['InvokeBtn','Save']);
+ $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]);
+ $w->OnDestroy(['CancelCmd', $w]);
+
+ # Build the focus group for all the entries
+ $w->FG_Create;
+ $w->FG_BindIn($ent, ['EntFocusIn', $w]);
+ $w->FG_BindOut($ent, ['EntFocusOut', $w]);
+
+ $w->SetPath(_cwd());
+
+ $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef],
+ -filetypes => ['PASSIVE', undef, undef, undef],
+ -initialdir => ['PASSIVE', undef, undef, undef],
+ -initialfile => ['PASSIVE', undef, undef, undef],
+# -sortcmd => ['PASSIVE', undef, undef, sub { lc($a) cmp lc($b) }],
+ -sortcmd => ['PASSIVE', undef, undef, sub { lc($_[0]) cmp lc($_[1]) }],
+ -title => ['PASSIVE', undef, undef, undef],
+ -type => ['PASSIVE', undef, undef, 'open'],
+ -filter => ['PASSIVE', undef, undef, '*'],
+ -force => ['PASSIVE', undef, undef, 0],
+ -multiple => ['PASSIVE', undef, undef, 0],
+ 'DEFAULT' => [$icons],
+ );
+ # So-far-failed attempt to break reference loops ...
+ $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId));
+ $w;
+}
+
+# -initialdir fix with ResolveFile
+sub Show {
+ my $w = shift;
+
+ $w->configure(@_);
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+
+ if (Tk::Exists($w->Parent) && $w->Parent->viewable) {
+ $w->transient($w->Parent);
+ }
+
+ # set the default directory and selection according to the -initial
+ # settings
+ {
+ my $initialdir = $w->cget(-initialdir);
+ if (defined $initialdir) {
+ my ($flag, $path, $file) = ResolveFile($initialdir, 'junk');
+ if ($flag eq 'OK' or $flag eq 'FILE') {
+ $w->{'selectPath'} = $path;
+ } else {
+ $w->Error("\"$initialdir\" is not a valid directory");
+ }
+ }
+ $w->{'selectFile'} = $w->cget(-initialfile);
+ }
+
+ # Set -multiple to a one or zero value (not other boolean types
+ # like "yes") so we can use it in tests more easily.
+ if ($w->cget('-type') ne 'open') {
+ $w->configure(-multiple => 0);
+ } else {
+ $w->configure(-multiple => !!$w->cget('-multiple'));
+ }
+ $w->{'icons'}->configure(-multiple => $w->cget('-multiple'));
+
+ # Initialize the file types menu
+ my $typeMenuBtn = $w->{'typeMenuBtn'};
+ my $typeMenuLab = $w->{'typeMenuLab'};
+ if (defined $w->cget('-filetypes')) {
+ my(@filetypes) = GetFileTypes($w->cget('-filetypes'));
+ my $typeMenu = $typeMenuBtn->cget(-menu);
+ $typeMenu->delete(0, 'end');
+ foreach my $ft (@filetypes) {
+ my $title = $ft->[0];
+ my $filter = join(' ', @{ $ft->[1] });
+ $typeMenuBtn->command
+ (-label => $title,
+ -command => ['SetFilter', $w, $title, $filter],
+ );
+ }
+ $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] }));
+ $typeMenuBtn->configure(-state => 'normal');
+ $typeMenuLab->configure(-state => 'normal');
+ } else {
+#XXX $w->configure(-filter => '*');
+ $typeMenuBtn->configure(-state => 'disabled',
+ -takefocus => 0);
+ $typeMenuLab->configure(-state => 'disabled');
+ }
+ $w->UpdateWhenIdle;
+
+ {
+ my $title = $w->cget(-title);
+ if (!defined $title) {
+ my $type = $w->cget(-type);
+ $title = ($type eq 'dir') ? 'Choose Directory'
+ : ($type eq 'save') ? 'Save As' : 'Open';
+ }
+ $w->title($title);
+ }
+
+ # Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display and de-iconify it.
+ $w->withdraw;
+ $w->idletasks;
+ if (0)
+ {
+ #XXX use Tk::Wm::Popup? or Tk::PlaceWindow?
+ my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx);
+ my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty);
+ $w->geometry("+$x+$y");
+ $w->deiconify;
+ }
+ else
+ {
+ $w->Popup;
+ }
+
+ # Set a grab and claim the focus too.
+#XXX use Tk::setFocusGrab when it's available
+ my $oldFocus = $w->focusCurrent;
+ my $oldGrab = $w->grabCurrent;
+ my $grabStatus = $oldGrab->grabStatus if ($oldGrab);
+ $w->grab;
+ my $ent = $w->{'ent'};
+ $ent->focus;
+ $ent->delete(0, 'end');
+ if (defined $w->{'selectFile'} && $w->{'selectFile'} ne '') {
+ $ent->insert(0, $w->{'selectFile'});
+ $ent->selectionRange(0,'end');
+ $ent->icursor('end');
+ }
+
+ # 8. Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+ $w->waitVariable(\$w->{'selectFilePath'});
+ eval {
+ $oldFocus->focus if $oldFocus;
+ };
+ if (Tk::Exists($w)) { # widget still exists
+ $w->grabRelease;
+ $w->withdraw;
+ }
+ if (Tk::Exists($oldGrab) && $oldGrab->viewable) {
+ if ($grabStatus eq 'global') {
+ $oldGrab->grabGlobal;
+ } else {
+ $oldGrab->grab;
+ }
+ }
+ return $w->{'selectFilePath'};
+}
+
+# tkFDialog_UpdateWhenIdle --
+#
+# Creates an idle event handler which updates the dialog in idle
+# time. This is important because loading the directory may take a long
+# time and we don't want to load the same directory for multiple times
+# due to multiple concurrent events.
+#
+sub UpdateWhenIdle {
+ my $w = shift;
+ if (exists $w->{'updateId'}) {
+ return;
+ } else {
+ $w->{'updateId'} = $w->after('idle', [$w, 'Update']);
+ }
+}
+
+# tkFDialog_Update --
+#
+# Loads the files and directories into the IconList widget. Also
+# sets up the directory option menu for quick access to parent
+# directories.
+#
+sub Update {
+ my $w = shift;
+ my $dataName = $w->name;
+
+ # This proc may be called within an idle handler. Make sure that the
+ # window has not been destroyed before this proc is called
+ if (!Tk::Exists($w) || $w->class ne 'FBox') {
+ return;
+ } else {
+ delete $w->{'updateId'};
+ }
+ unless (defined $folderImage->{$w->MainWindow}) {
+ require Tk::Pixmap;
+ $folderImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('folder.xpm'));
+ $fileImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('file.xpm'));
+ }
+ my $folder = $folderImage->{$w->MainWindow};
+ my $file = $fileImage->{$w->MainWindow};
+ my $appPWD = _cwd();
+ if (!ext_chdir($w->{'selectPath'})) {
+ # We cannot change directory to $data(selectPath). $data(selectPath)
+ # should have been checked before tkFDialog_Update is called, so
+ # we normally won't come to here. Anyways, give an error and abort
+ # action.
+ $w->messageBox(-type => 'OK',
+ -message => 'Cannot change to the directory "' .
+ $w->{'selectPath'} . "\".\nPermission denied.",
+ -icon => 'warning',
+ );
+ ext_chdir($appPWD);
+ return;
+ }
+
+ # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
+ # so the user may still click and cause havoc ...
+ my $ent = $w->{'ent'};
+ my $entCursor = $ent->cget(-cursor);
+ my $dlgCursor = $w->cget(-cursor);
+ $ent->configure(-cursor => 'watch');
+ $w->configure(-cursor => 'watch');
+ $w->idletasks;
+ my $icons = $w->{'icons'};
+ $icons->DeleteAll;
+
+ # Make the dir & file list
+ my $cwd = _cwd();
+ local *FDIR;
+ if (opendir(FDIR, $cwd)) {
+ my @files;
+# my $sortcmd = $w->cget(-sortcmd);
+ my $sortcmd = sub { $w->cget(-sortcmd)->($a,$b) };
+ my $flt = $w->cget(-filter);
+ my $fltcb;
+ if (ref $flt eq 'CODE') {
+ $fltcb = $flt;
+ } else {
+ $flt = _rx_to_glob($flt);
+ }
+ my $type_dir = $w->cget(-type) eq 'dir';
+ foreach my $f (sort $sortcmd readdir(FDIR)) {
+ next if $f eq '.' or $f eq '..';
+ next if $type_dir && ! -d "$cwd/$f"; # XXX use File::Spec?
+ if ($fltcb) {
+ next if !$fltcb->($w, $f, $cwd);
+ } else {
+ next if -f $f && $f !~ m!$flt!;
+ }
+ if (-d $f) {
+ $icons->Add($folder, $f);
+ } else {
+ push @files, $f;
+ }
+ }
+ closedir(FDIR);
+ $icons->Add($file, @files);
+ }
+
+ $icons->Arrange;
+
+ # Update the Directory: option menu
+ my @list;
+ my $dir = '';
+ foreach my $subdir (TclFileSplit($w->{'selectPath'})) {
+ $dir = TclFileJoin($dir, $subdir);
+ push @list, $dir;
+ }
+ my $dirMenu = $w->{'dirMenu'};
+ $dirMenu->configure(-options => \@list);
+
+ # Restore the PWD to the application's PWD
+ ext_chdir($appPWD);
+
+ # Restore the Save label
+ if ($w->cget(-type) eq 'save') {
+ $w->{'okBtn'}->configure(-text => 'Save');
+ }
+
+ # turn off the busy cursor.
+ $ent->configure(-cursor => $entCursor);
+ $w->configure(-cursor => $dlgCursor);
+}
+
+# tkFDialog_SetPathSilently --
+#
+# Sets data(selectPath) without invoking the trace procedure
+#
+sub SetPathSilently {
+ my($w, $path) = @_;
+
+ $w->{'selectPath'} = $path;
+}
+
+# This proc gets called whenever data(selectPath) is set
+#
+sub SetPath {
+ my $w = shift;
+ $w->{'selectPath'} = $_[0] if @_;
+ $w->UpdateWhenIdle;
+}
+
+# This proc gets called whenever data(filter) is set
+#
+#XXX here's much more code in the tcl version ... check it out
+sub SetFilter {
+ my($w, $title, $filter) = @_;
+ $w->configure(-filter => $filter);
+ $w->{'typeMenuBtn'}->configure(-text => $title,
+ -indicatoron => 1);
+ $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0);
+ $w->UpdateWhenIdle;
+}
+
+# tkFDialogResolveFile --
+#
+# Interpret the user's text input in a file selection dialog.
+# Performs:
+#
+# (1) ~ substitution
+# (2) resolve all instances of . and ..
+# (3) check for non-existent files/directories
+# (4) check for chdir permissions
+#
+# Arguments:
+# context: the current directory you are in
+# text: the text entered by the user
+# defaultext: the default extension to add to files with no extension
+#
+# Return value:
+# [list $flag $directory $file]
+#
+# flag = OK : valid input
+# = PATTERN : valid directory/pattern
+# = PATH : the directory does not exist
+# = FILE : the directory exists but the file doesn't
+# exist
+# = CHDIR : Cannot change to the directory
+# = ERROR : Invalid entry
+#
+# directory : valid only if flag = OK or PATTERN or FILE
+# file : valid only if flag = OK or PATTERN
+#
+# directory may not be the same as context, because text may contain
+# a subdirectory name
+#
+sub ResolveFile {
+ my($context, $text, $defaultext) = @_;
+ my $appPWD = _cwd();
+ my $path = JoinFile($context, $text);
+ # If the file has no extension, append the default. Be careful not
+ # to do this for directories, otherwise typing a dirname in the box
+ # will give back "dirname.extension" instead of trying to change dir.
+ if (!-d $path && $path !~ /\..+$/ && defined $defaultext) {
+ $path = "$path$defaultext";
+ }
+ # Cannot just test for existance here as non-existing files are
+ # not an error for getSaveFile type dialogs.
+ # return ('ERROR', $path, "") if (!-e $path);
+ my($directory, $file, $flag);
+ if (-e $path) {
+ if (-d $path) {
+ if (!ext_chdir($path)) {
+ return ('CHDIR', $path, '');
+ }
+ $directory = _cwd();
+ $file = '';
+ $flag = 'OK';
+ ext_chdir($appPWD);
+ } else {
+ my $dirname = File::Basename::dirname($path);
+ if (!ext_chdir($dirname)) {
+ return ('CHDIR', $dirname, '');
+ }
+ $directory = _cwd();
+ $file = File::Basename::basename($path);
+ $flag = 'OK';
+ ext_chdir($appPWD);
+ }
+ } else {
+ my $dirname = File::Basename::dirname($path);
+ if (-e $dirname) {
+ if (!ext_chdir($dirname)) {
+ return ('CHDIR', $dirname, '');
+ }
+ $directory = _cwd();
+ $file = File::Basename::basename($path);
+ if ($file =~ /[*?]/) {
+ $flag = 'PATTERN';
+ } else {
+ $flag = 'FILE';
+ }
+ ext_chdir($appPWD);
+ } else {
+ $directory = $dirname;
+ $file = File::Basename::basename($path);
+ $flag = 'PATH';
+ }
+ }
+ return ($flag,$directory,$file);
+}
+
+# Gets called when the entry box gets keyboard focus. We clear the selection
+# from the icon list . This way the user can be certain that the input in the
+# entry box is the selection.
+#
+sub EntFocusIn {
+ my $w = shift;
+ my $ent = $w->{'ent'};
+ if ($ent->get ne '') {
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } else {
+ $ent->selectionClear;
+ }
+#XXX is this missing in the tcl version, too??? $w->{'icons'}->Selection('clear');
+ my $okBtn = $w->{'okBtn'};
+ if ($w->cget(-type) ne 'save') {
+ $okBtn->configure(-text => 'Open');
+ } else {
+ $okBtn->configure(-text => 'Save');
+ }
+}
+
+sub EntFocusOut {
+ my $w = shift;
+ $w->{'ent'}->selectionClear;
+}
+
+# Gets called when user presses Return in the "File name" entry.
+#
+sub ActivateEnt {
+ my $w = shift;
+ my $ent = $w->{'ent'};
+ my $text = $ent->get;
+ if ($w->cget(-multiple)) {
+ # For the multiple case we have to be careful to get the file
+ # names as a true list, watching out for a single file with a
+ # space in the name. Thus we query the IconList directly.
+
+ $w->{'selectFile'} = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ $w->VerifyFileName($w->{'icons'}->Get($item));
+ }
+ } else {
+ $w->VerifyFileName($text);
+ }
+}
+
+# Verification procedure
+#
+sub VerifyFileName {
+ my($w, $text) = @_;
+#XXX leave this here?
+# $text =~ s/^\s+//;
+# $text =~ s/\s+$//;
+ my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text,
+ $w->cget(-defaultextension));
+ my $ent = $w->{'ent'};
+ if ($flag eq 'OK') {
+ if ($file eq '') {
+ # user has entered an existing (sub)directory
+ $w->SetPath($path);
+ $ent->delete(0, 'end');
+ } else {
+ $w->SetPathSilently($path);
+ if ($w->cget(-multiple)) {
+ push @{ $w->{'selectFile'} }, $file;
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+ } elsif ($flag eq 'PATTERN') {
+ $w->SetPath($path);
+ $w->configure(-filter => $file);
+ } elsif ($flag eq 'FILE') {
+ if ($w->cget(-type) eq 'open') {
+ $w->messageBox(-icon => 'warning',
+ -type => 'OK',
+ -message => 'File "' . TclFileJoin($path, $file)
+ . '" does not exist.');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($w->cget(-type) eq 'save') {
+ $w->SetPathSilently($path);
+ if ($w->cget(-multiple)) {
+ push @{ $w->{'selectFile'} }, $file;
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+ } elsif ($flag eq 'PATH') {
+ $w->messageBox(-icon => 'warning',
+ -type => 'OK',
+ -message => "Directory \'$path\' does not exist.");
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'CHDIR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Cannot change to the directory \"$path\".\nPermission denied.",
+ -icon => 'warning');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'ERROR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Invalid file name \"$path\".",
+ -icon => 'warning');
+ $ent->selectionRange(0, 'end');
+ $ent->icursor('end');
+ }
+}
+
+# Gets called when user presses the Alt-s or Alt-o keys.
+#
+sub InvokeBtn {
+ my($w, $key) = @_;
+ my $okBtn = $w->{'okBtn'};
+ $okBtn->invoke if ($okBtn->cget(-text) eq $key);
+}
+
+# Gets called when user presses the "parent directory" button
+#
+sub UpDirCmd {
+ my $w = shift;
+ $w->SetPath(File::Basename::dirname($w->{'selectPath'}))
+ unless ($w->{'selectPath'} eq '/');
+}
+
+# Join a file name to a path name. The "file join" command will break
+# if the filename begins with ~
+sub JoinFile {
+ my($path, $file) = @_;
+ if ($file =~ /^~/ && -e "$path/$file") {
+ TclFileJoin($path, "./$file");
+ } else {
+ TclFileJoin($path, $file);
+ }
+}
+
+# XXX replace with File::Spec when perl/Tk depends on 5.005
+sub TclFileJoin {
+ my $path = '';
+ foreach (@_) {
+ if (m|^/|) {
+ $path = $_;
+ }
+ elsif (m|^[a-z]:/|i) { # DOS-ish
+ $path = $_;
+ } elsif ($_ eq '~') {
+ $path = _get_homedir();
+ } elsif (m|^~/(.*)|) {
+ $path = _get_homedir() . "/" . $1;
+ } elsif (m|^~([^/]+)(.*)|) {
+ my($user, $p) = ($1, $2);
+ my $dir = _get_homedir($user);
+ if (!defined $dir) {
+ $path = "~$user$p";
+ } else {
+ $path = $dir . $p;
+ }
+ } elsif ($path eq '/' or $path eq '') {
+ $path .= $_;
+ } else {
+ $path .= "/$_";
+ }
+ }
+ $path;
+}
+
+sub TclFileSplit {
+ my $path = shift;
+ my @comp;
+ $path =~ s|/+|/|g; # strip multiple slashes
+ if ($path =~ m|^/|) {
+ push @comp, '/';
+ $path = substr($path, 1);
+ }
+ push @comp, split /\//, $path;
+ @comp;
+}
+
+# Gets called when user presses the "OK" button
+#
+sub OkCmd {
+ my $w = shift;
+ my $from = shift || "button";
+
+ my $filenames = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ push @$filenames, $w->{'icons'}->Get($item);
+ }
+
+ my $filename = $filenames->[0];
+ if ($w->cget('-type') eq 'dir' && $from ne "iconlist") {
+ my $file = $filename eq '' ? $w->{'selectPath'} : JoinFile($w->{'selectPath'}, $filename);
+ $w->Done($file);
+ } elsif ((@$filenames && !$w->cget('-multiple')) ||
+ ($w->cget('-multiple') && @$filenames == 1)) {
+ my $file = JoinFile($w->{'selectPath'}, $filename);
+ if (-d $file) {
+ $w->ListInvoke($filename);
+ return;
+ }
+ }
+
+ $w->ActivateEnt;
+}
+
+# Gets called when user presses the "Cancel" button
+#
+sub CancelCmd {
+ my $w = shift;
+ undef $w->{'selectFilePath'};
+}
+
+# Gets called when user browses the IconList widget (dragging mouse, arrow
+# keys, etc)
+#
+sub ListBrowse {
+ my($w) = @_;
+
+ my $text = [];
+ for my $item ($w->{'icons'}->Curselection) {
+ push @$text, $w->{'icons'}->Get($item);
+ }
+ return if @$text == 0;
+ my $isDir;
+ if (@$text > 1) {
+ my $newtext = [];
+ for my $file (@$text) {
+ my $fullfile = JoinFile($w->{'selectPath'}, $file);
+ if (!-d $fullfile) {
+ push @$newtext, $file;
+ }
+ }
+ $text = $newtext;
+ $isDir = 0;
+ } else {
+ my $file = JoinFile($w->{'selectPath'}, $text->[0]);
+ $isDir = -d $file;
+ }
+ my $ent = $w->{'ent'};
+ my $okBtn = $w->{'okBtn'};
+ if (!$isDir) {
+ $ent->delete(qw(0 end));
+ $ent->insert(0, "@$text"); # XXX quote!
+
+ if ($w->cget('-type') ne 'save') {
+ $okBtn->configure(-text => 'Open');
+ } else {
+ $okBtn->configure(-text => 'Save');
+ }
+ } else {
+ $okBtn->configure(-text => 'Open');
+ }
+}
+
+# Gets called when user invokes the IconList widget (double-click,
+# Return key, etc)
+#
+sub ListInvoke {
+ my($w, @filenames) = @_;
+ return if !@filenames;
+ my $file = JoinFile($w->{'selectPath'}, $filenames[0]);
+ if (-d $file) {
+ my $appPWD = _cwd();
+ if (!ext_chdir($file)) {
+ $w->messageBox(-type => 'OK',
+ -message => "Cannot change to the directory \"$file\".\nPermission denied.",
+ -icon => 'warning');
+ } else {
+ ext_chdir($appPWD);
+ $w->SetPath($file);
+ }
+ } else {
+ if ($w->cget('-multiple')) {
+ $w->{'selectFile'} = [@filenames];
+ } else {
+ $w->{'selectFile'} = $file;
+ }
+ $w->Done;
+ }
+}
+
+# tkFDialog_Done --
+#
+# Gets called when user has input a valid filename. Pops up a
+# dialog box to confirm selection when necessary. Sets the
+# tkPriv(selectFilePath) variable, which will break the "tkwait"
+# loop in tkFDialog and return the selected filename to the
+# script that calls tk_getOpenFile or tk_getSaveFile
+#
+sub Done {
+ my $w = shift;
+ my $selectFilePath = (@_) ? shift : '';
+ if ($selectFilePath eq '') {
+ if ($w->cget('-multiple')) {
+ $selectFilePath = [];
+ for my $f (@{ $w->{'selectFile'} }) {
+ push @$selectFilePath, JoinFile($w->{'selectPath'}, $f);
+ }
+ } else {
+ $selectFilePath = JoinFile($w->{'selectPath'},
+ $w->{'selectFile'});
+ }
+ if ($w->cget(-type) eq 'save' and
+ -e $selectFilePath and
+ !$w->cget(-force)) {
+ my $reply = $w->messageBox
+ (-icon => 'warning',
+ -type => 'YesNo',
+ -message => "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?");
+ return unless (lc($reply) eq 'yes');
+ }
+ }
+ $w->{'selectFilePath'} = ($selectFilePath ne '' ? $selectFilePath : undef);
+}
+
+sub FDialog {
+ my $cmd = shift;
+ if ($cmd =~ /Save/) {
+ push @_, -type => 'save';
+ } elsif ($cmd =~ /Directory/) {
+ push @_, -type => 'dir';
+ }
+ Tk::DialogWrapper('FBox', $cmd, @_);
+}
+
+# tkFDGetFileTypes --
+#
+# Process the string given by the -filetypes option of the file
+# dialogs. Similar to the C function TkGetFileFilters() on the Mac
+# and Windows platform.
+#
+sub GetFileTypes {
+ my $in = shift;
+ my %fileTypes;
+ foreach my $t (@$in) {
+ if (@$t < 2 || @$t > 3) {
+ require Carp;
+ Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\"");
+ }
+ push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY'
+ ? @{ $t->[1] }
+ : $t->[1]);
+ }
+
+ my @types;
+ my %hasDoneType;
+ my %hasGotExt;
+ foreach my $t (@$in) {
+ my $label = $t->[0];
+ my @exts;
+
+ next if (exists $hasDoneType{$label});
+
+ my $name = "$label (";
+ my $sep = '';
+ foreach my $ext (@{ $fileTypes{$label} }) {
+ next if ($ext eq '');
+ $ext =~ s/^\./*./;
+ if (!exists $hasGotExt{$label}->{$ext}) {
+ $name .= "$sep$ext";
+ push @exts, $ext;
+ $hasGotExt{$label}->{$ext}++;
+ }
+ $sep = ',';
+ }
+ $name .= ')';
+ push @types, [$name, \@exts];
+
+ $hasDoneType{$label}++;
+ }
+
+ return @types;
+}
+
+# ext_chdir --
+#
+# Change directory with tilde substitution
+#
+sub ext_chdir {
+ my $dir = shift;
+ if ($dir eq '~') {
+ chdir _get_homedir();
+ } elsif ($dir =~ m|^~/(.*)|) {
+ chdir _get_homedir() . "/" . $1;
+ } elsif ($dir =~ m|^~([^/]+(.*))|) {
+ chdir _get_homedir($1) . $2;
+ } else {
+ chdir $dir;
+ }
+}
+
+# _get_homedir --
+#
+# Get home directory of the current user
+#
+sub _get_homedir {
+ my($user) = @_;
+ if (!defined $user) {
+ eval {
+ local $SIG{__DIE__};
+ (getpwuid($<))[7];
+ } || $ENV{HOME} || undef; # chdir undef changes to home directory, too
+ } else {
+ eval {
+ local $SIG{__DIE__};
+ (getpwnam($user))[7];
+ };
+ }
+}
+
+sub _cwd {
+ #Cwd::cwd();
+ Cwd::fastcwd(); # this is taint-safe
+}
+
+sub _untaint {
+ my $s = shift;
+ $s =~ /^(.*)$/;
+ $1;
+}
+
+sub _rx_to_glob {
+ my $arg = shift;
+ $arg = join('|', split(' ', $arg));
+ $arg =~ s!([\.\+])!\\$1!g;
+ $arg =~ s!\*!.*!g;
+ $arg = "^" . $arg . "\$";
+ if ($] >= 5.005) {
+ $arg = qr/$arg/;
+ }
+ $arg;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm
new file mode 100644
index 00000000000..d2070049d82
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/FileSelect.pm
@@ -0,0 +1,578 @@
+package Tk::FileSelect;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+@EXPORT_OK = qw(glob_to_re);
+
+use Tk qw(Ev);
+use strict;
+use Carp;
+use base qw(Tk::Toplevel);
+use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar);
+use File::Basename;
+
+Construct Tk::Widget 'FileSelect';
+
+use vars qw(%error_text);
+%error_text = (
+ '-r' => 'is not readable by effective uid/gid',
+ '-w' => 'is not writeable by effective uid/gid',
+ '-x' => 'is not executable by effective uid/gid',
+ '-R' => 'is not readable by real uid/gid',
+ '-W' => 'is not writeable by real uid/gid',
+ '-X' => 'is not executable by real uid/gid',
+ '-o' => 'is not owned by effective uid/gid',
+ '-O' => 'is not owned by real uid/gid',
+ '-e' => 'does not exist',
+ '-z' => 'is not of size zero',
+ '-s' => 'does not exists or is of size zero',
+ '-f' => 'is not a file',
+ '-d' => 'is not a directory',
+ '-l' => 'is not a link',
+ '-S' => 'is not a socket',
+ '-p' => 'is not a named pipe',
+ '-b' => 'is not a block special file',
+ '-c' => 'is not a character special file',
+ '-u' => 'is not setuid',
+ '-g' => 'is not setgid',
+ '-k' => 'is not sticky',
+ '-t' => 'is not a terminal file',
+ '-T' => 'is not a text file',
+ '-B' => 'is not a binary file',
+ '-M' => 'has no modification date/time',
+ '-A' => 'has no access date/time',
+ '-C' => 'has no inode change date/time',
+ );
+
+# Documentation after __END__
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ if ($Tk::VERSION < 804) {
+ *FDialog = \&Tk::FileSelect::FDialog;
+ *MotifFDialog = \&Tk::FileSelect::FDialog;
+ } else {
+ *tk_getOpenFile = sub {
+ Tk::FileSelect::FDialog("tk_getOpenFile", @_);
+ };
+ *tk_getSaveFile = sub {
+ Tk::FileSelect::FDialog("tk_getSaveFile", @_);
+ };
+ }
+ }
+}
+
+sub Cancel
+{
+ my ($cw) = @_;
+ $cw->{Selected} = undef;
+ $cw->withdraw unless $cw->cget('-transient');
+}
+
+sub Accept {
+
+ # Accept the file or directory name if possible.
+
+ my ($cw) = @_;
+
+ my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner);
+ my $leaf = undef;
+ my $leaves;
+
+ if (defined $so and
+ $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) {
+ $leaves = [$cw->Subwidget('dir_list')->getSelected];
+ $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves);
+ } else {
+ $leaves = [$cw->Subwidget('file_list')->getSelected];
+ $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves);
+ }
+
+ foreach $leaf (@$leaves)
+ {
+ if (defined $leaf and $leaf ne '') {
+ if (!$cw->cget('-create') || -e "$path/$leaf")
+ {
+ foreach (@{$cw->cget('-verify')}) {
+ my $r = ref $_;
+ if (defined $r and $r eq 'ARRAY') {
+ #local $_ = $leaf; # use strict var problem here
+ return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]);
+ } else {
+ my $s = eval "$_ '$path/$leaf'";
+ print $@ if $@;
+ if (not $s) {
+ my $err;
+ if (substr($_,0,1) eq '!')
+ {
+ my $t = substr($_,1);
+ if (exists $error_text{$t})
+ {
+ $err = $error_text{$t};
+ $err =~ s/\b(?:no|not) //;
+ }
+ }
+ $err = $error_text{$_} unless defined $err;
+ $err = "failed '$_' test" unless defined $err;
+ $cw->Error("'$leaf' $err.");
+ return;
+ }
+ }
+ } # forend
+ }
+ else
+ {
+ unless (-w $path)
+ {
+ $cw->Error("Cannot write to $path");
+ return;
+ }
+ }
+ $leaf = $path . '/' . $leaf;
+ } else {
+ $leaf = undef;
+ }
+ }
+ if (scalar(@$leaves))
+ {
+ my $sm = $cw->Subwidget('file_list')->cget(-selectmode);
+ $cw->{Selected} = $leaves;
+ my $command = $cw->cget('-command');
+ $command->Call(@{$cw->{Selected}}) if defined $command;
+ }
+
+} # end Accept
+
+sub Accept_dir
+{
+ my ($cw,$new) = @_;
+ my $dir = $cw->cget('-directory');
+ $cw->configure(-directory => "$dir/$new");
+}
+
+sub Populate {
+
+ my ($w, $args) = @_;
+
+ require Tk::Listbox;
+ require Tk::Button;
+ require Tk::Dialog;
+ require Tk::Toplevel;
+ require Tk::LabEntry;
+ require Cwd;
+
+ $w->SUPER::Populate($args);
+ $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]);
+
+ $w->{'reread'} = 0;
+ $w->withdraw;
+
+ # Create directory/filter entry, place at the top.
+ my $e = $w->Component(
+ LabEntry => 'dir_entry',
+ -textvariable => \$w->{DirectoryString},
+ -labelVariable => \$w->{Configure}{-dirlabel},
+ );
+ $e->pack(-side => 'top', -expand => 0, -fill => 'x');
+ $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]);
+
+ # Create file entry, place at the bottom.
+ $e = $w->Component(
+ LabEntry => 'file_entry',
+ -textvariable => \$w->{Configure}{-initialfile},
+ -labelVariable => \$w->{Configure}{-filelabel},
+ );
+ $e->pack(-side => 'bottom', -expand => 0, -fill => 'x');
+ $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]);
+ $e->bind('<FocusIn>' => [$w => 'SelectionClear']);
+
+ # Create directory scrollbox, place at the left-middle.
+ my $b = $w->Component(
+ ScrlListbox => 'dir_list',
+ -labelVariable => \$w->{Configure}{-dirlistlabel},
+ -scrollbars => 'se',
+ );
+ $b->pack(-side => 'left', -expand => 1, -fill => 'both');
+ $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['getSelected'])]);
+
+ # Add a label.
+
+ my $f = $w->Frame();
+ $f->pack(-side => 'right', -fill => 'y', -expand => 0);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'},
+ -command => [ 'Accept', $w ],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'},
+ -command => [ 'Cancel', $w ],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-resetlabel'},
+ -command => [$w => 'configure','-directory','.'],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+ $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-homelabel'},
+ -command => [$w => 'configure','-directory',$ENV{'HOME'}],
+ );
+ $b->pack(-side => 'top', -fill => 'x', -expand => 1);
+
+ # Create file scrollbox, place at the right-middle.
+
+ $b = $w->Component(
+ ScrlListbox => 'file_list',
+ -labelVariable => \$w->{Configure}{-filelistlabel},
+ -scrollbars => 'se',
+ );
+ $b->pack(-side => 'right', -expand => 1, -fill => 'both');
+ $b->bind('<Double-1>' => [$w => 'Accept']);
+
+ # Create -very dialog.
+
+ my $v = $w->Component(
+ Dialog => 'dialog',
+ -title => 'Verify Error',
+ -bitmap => 'error',
+ -buttons => ['Dismiss'],
+ );
+
+ $w->ConfigSpecs(
+ -width => [ ['file_list','dir_list'], undef, undef, 14 ],
+ -height => [ ['file_list','dir_list'], undef, undef, 14 ],
+ -directory => [ 'METHOD', undef, undef, '.' ],
+ -initialdir => '-directory',
+ -filelabel => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ],
+ -initialfile => [ 'PASSIVE', undef, undef, '' ],
+ -filelistlabel => [ 'PASSIVE', undef, undef, 'Files' ],
+ -filter => [ 'METHOD', undef, undef, undef ],
+ -defaultextension => [ 'METHOD', undef, undef, undef ],
+ -regexp => [ 'METHOD', undef, undef, undef ],
+ -dirlistlabel => [ 'PASSIVE', undef, undef, 'Directories'],
+ -dirlabel => [ 'PASSIVE', undef, undef, 'Directory'],
+ '-accept' => [ 'CALLBACK',undef,undef, undef ],
+ -command => [ 'CALLBACK',undef,undef, undef ],
+ -transient => [ 'PASSIVE', undef, undef, 1 ],
+ -verify => [ 'PASSIVE', undef, undef, ['!-d'] ],
+ -create => [ 'PASSIVE', undef, undef, 0 ],
+ -acceptlabel => [ 'PASSIVE', undef, undef, 'Accept'],
+ -cancellabel => [ 'PASSIVE', undef, undef, 'Cancel'],
+ -resetlabel => [ 'PASSIVE', undef, undef, 'Reset'],
+ -homelabel => [ 'PASSIVE', undef, undef, 'Home'],
+ DEFAULT => [ 'file_list' ],
+ );
+ $w->Delegates(DEFAULT => 'file_list');
+
+ return $w;
+
+} # end Populate
+
+sub translate
+ {
+ my ($bs,$ch) = @_;
+ return "\\$ch" if (length $bs);
+ return '.*' if ($ch eq '*');
+ return '.' if ($ch eq '?');
+ return "\\." if ($ch eq '.');
+ return "\\/" if ($ch eq '/');
+ return "\\\\" if ($ch eq '\\');
+ return $ch;
+}
+
+sub glob_to_re
+{
+ my $regex = shift;
+ $regex =~ s/(\\?)(.)/&translate($1,$2)/ge;
+ return sub { shift =~ /^${regex}$/ };
+}
+
+sub filter
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-filter'};
+ if (@_ > 1 || !defined($$var))
+ {
+ $val = '*' unless defined $val;
+ $$var = $val;
+ $cw->{'match'} = glob_to_re($val) unless defined $cw->{'match'};
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw,$cw->cget('-directory')])
+ }
+ }
+ return $$var;
+}
+
+sub regexp
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-regexp'};
+ if (@_ > 1)
+ {
+ $$var = $val;
+ $cw->{'match'} = (defined $val) ? sub { shift =~ m|^${val}$| } : sub { 1 };
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ return $$var;
+}
+
+sub defaultextension
+{
+ my ($cw,$val) = @_;
+ if (@_ > 1)
+ {
+ $val = '' unless defined $val;
+ $val = ".$val" if ($val !~ /^\./);
+ $cw->filter("*$val");
+ }
+ else
+ {
+ $val = $cw->filter;
+ my ($ext) = $val =~ /(\.[^\.]*)$/;
+ return $ext;
+ }
+}
+
+sub directory
+{
+ my ($cw,$dir) = @_;
+ my $var = \$cw->{Configure}{'-directory'};
+ if (@_ > 1 && defined $dir)
+ {
+ if (substr($dir,0,1) eq '~')
+ {
+ if (substr($dir,1,1) eq '/')
+ {
+ $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1);
+ }
+ else
+ {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#);
+ $dir = (getpwnam($uid))[7] . $rest;
+ }
+ }
+ my $revert_dir = sub
+ {
+ my $message = shift;
+ $$var = $cw->{OldDirectory};
+ $cw->messageBox(-message => $message, -icon => 'error');
+ if (!defined $$var)
+ {
+ # OldDirectory was never set, so force reread...
+ $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below...
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ $$var;
+ };
+ $dir =~ s#([^/\\])[\\/]+$#$1#;
+ if (-d $dir)
+ {
+ unless (Tk::tainting())
+ {
+ my $pwd = Cwd::getcwd();
+ if (chdir( (defined($dir) ? $dir : '') ) )
+ {
+ my $new = Cwd::getcwd();
+ if ($new)
+ {
+ $dir = $new;
+ }
+ else
+ {
+ return $revert_dir->("Cannot getcwd in '$dir'");
+ }
+ if (!chdir($pwd))
+ {
+ return $revert_dir->("Cannot change directory to $pwd:\n$!");
+ }
+ $$var = $dir;
+ }
+ else
+ {
+ return $revert_dir->("Cannot change directory to $dir:\n$!");
+ }
+ $$var = $cw->{OldDirectory} = $dir;
+ }
+ unless ($cw->{'reread'}++)
+ {
+ $cw->Busy;
+ $cw->afterIdle(['reread',$cw])
+ }
+ }
+ }
+ return $$var;
+}
+
+sub reread
+{
+ my ($w) = @_;
+ my $dir = $w->cget('-directory');
+ if (defined $dir)
+ {
+ if (!defined $w->cget('-filter') or $w->cget('-filter') eq '')
+ {
+ $w->configure('-filter', '*');
+ }
+ my $dl = $w->Subwidget('dir_list');
+ $dl->delete(0, 'end');
+ $dl->selectionClear(0,'end');
+ my $fl = $w->Subwidget('file_list');
+ $fl->delete(0, 'end');
+ local *DIR;
+ if (opendir(DIR, $dir))
+ {
+ my $file = $w->cget('-initialfile');
+ my $seen = 0;
+ my $accept = $w->cget('-accept');
+ foreach my $f (sort(readdir(DIR)))
+ {
+ next if ($f eq '.');
+ my $path = "$dir/$f";
+ if (-d $path)
+ {
+ $dl->insert('end', $f);
+ }
+ else
+ {
+ if (&{$w->{match}}($f))
+ {
+ if (!defined($accept) || $accept->Call($path))
+ {
+ $seen = $fl->index('end') if ($file && $f eq $file);
+ $fl->insert('end', $f)
+ }
+ }
+ }
+ }
+ closedir(DIR);
+ if ($seen)
+ {
+ $fl->selectionSet($seen);
+ $fl->see($seen);
+ }
+ else
+ {
+ $w->configure(-initialfile => undef) unless $w->cget('-create');
+ }
+ }
+ $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter');
+ }
+ $w->{'reread'} = 0;
+ $w->Unbusy if $w->{'Busy'};
+}
+
+sub validateDir
+{
+ my ($cw,$name) = @_;
+ my ($leaf,$base) = fileparse($name);
+ if ($leaf =~ /[*?]/)
+ {
+ $cw->configure('-directory' => $base,'-filter' => $leaf);
+ }
+ else
+ {
+ $cw->configure('-directory' => $name);
+ }
+}
+
+sub validateFile
+{
+ my ($cw,$name) = @_;
+ my $i = 0;
+ my $n = $cw->index('end');
+ # See if it is an existing file
+ for ($i= 0; $i < $n; $i++)
+ {
+ my $f = $cw->get($i);
+ if ($f eq $name)
+ {
+ $cw->selection('set',$i);
+ $cw->Accept;
+ }
+ }
+ # otherwise allow if -create is set, directory is writable
+ # and it passes filter and accept criteria
+ if ($cw->cget('-create'))
+ {
+ my $path = $cw->cget('-directory');
+ if (-w $path)
+ {
+ if (&{$cw->{match}}($name))
+ {
+ my $accept = $cw->cget('-accept');
+ my $full = "$path/$name";
+ if (!defined($accept) || $accept->Call($full))
+ {
+ $cw->{Selected} = [$full];
+ $cw->Callback(-command => @{$cw->{Selected}});
+ }
+ else
+ {
+ $cw->Error("$name is not 'acceptable'");
+ }
+ }
+ else
+ {
+ $cw->Error("$name does not match '".$cw->cget('-filter').'\'');
+ }
+ }
+ else
+ {
+ $cw->Error("Directory '$path' is not writable");
+ return;
+ }
+ }
+}
+
+sub Error
+{
+ my $cw = shift;
+ my $msg = shift;
+ my $dlg = $cw->Subwidget('dialog');
+ $dlg->configure(-text => $msg);
+ $dlg->Show;
+}
+
+sub Show
+{
+ my ($cw,@args) = @_;
+ if ($cw->cget('-transient')) {
+ $cw->Popup(@args);
+ $cw->focus;
+ $cw->waitVariable(\$cw->{Selected});
+ $cw->withdraw;
+ return defined($cw->{Selected})
+ ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0]
+ : undef;
+ } else {
+ $cw->Popup(@args);
+ }
+}
+
+sub FDialog
+{
+ my($cmd, %args) = @_;
+ if ($cmd =~ /Save/)
+ {
+ $args{-create} = 1;
+ $args{-verify} = [qw(!-d -w)];
+ }
+ delete $args{-filetypes};
+ delete $args{-force};
+ Tk::DialogWrapper('FileSelect',$cmd, %args);
+}
+
+1;
+
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm
new file mode 100644
index 00000000000..eb6465dbe61
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/FloatEntry.pm
@@ -0,0 +1,109 @@
+# Tranlation of FloatEnt.tcl in Tix4.1
+
+# TODO/IDEA:
+# o extract a widget (SimpleEntry?) without post/unpost methods
+# and derive FloatEntry fron this widget.
+
+package Tk::FloatEntry;
+use strict;
+
+BEGIN
+ {
+ use vars '$DEBUG';
+ $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0;
+ print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
+ }
+
+require Tk;
+require Tk::Widget;
+require Tk::Derived;
+require Tk::Entry;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixGrid/FloatEntry.pm#4 $
+
+use base qw(Tk::Derived Tk::Entry);
+
+Construct Tk::Widget 'FloatEntry';
+
+sub ClassInit
+ {
+ my ($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+ $mw->bind($class, '<Return>', 'invoke');
+ $mw->bind($class, '<FocusIn>', 'FocusIn');
+ $class;
+ }
+
+sub Populate
+ {
+ my ($e, $args) = @_;
+ $e->ConfigSpecs(
+ -value => ['METHOD', 'value', 'Value', undef],
+ -highlightthickness => [$e, 'highlightThickness', 'HighlightThickness', 0 ],
+ -command => ['CALLBACK', 'command', 'Command', undef],
+ );
+ print "FloatEntry Init: $e\n" if $DEBUG;
+ $e;
+ }
+
+## option method
+
+sub value
+ {
+ my $e = shift;
+ unless (@_)
+ {
+ return $e->get
+ }
+ $e->delete(0,'end');
+ $e->insert(0,$_[0]);
+ $e->selection('from', 0);
+ $e->selection('to', 'end');
+
+ }
+
+## public methods
+
+sub invoke
+ {
+ my ($e) = @_;
+ $e->Callback('-command', $e->get);
+ }
+
+sub post
+ {
+ my ($e, $x, $y, $dx, $dy) = @_;
+
+ $dx = $e->reqwidth unless defined $dx;
+ $dy = $e->reqheight unless defined $dy;
+
+ $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore');
+ $e->raise;
+ $e->focus;
+ }
+
+sub unpost
+ {
+ my ($e) = @_;
+ $e->place('forget');
+ }
+
+## bindings
+
+sub FocusIn
+ {
+ my ($e) = @_;
+
+ # FIX: xxx only if entry has not already focus
+ {
+ $e->focus;
+ $e->selection('from', 0);
+ $e->selection('to', 'end');
+ $e->icursor('end');
+ }
+ }
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Font.pm b/Master/tlpkg/tlperl/lib/Tk/Font.pm
new file mode 100644
index 00000000000..bb1b52cc7c5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Font.pm
@@ -0,0 +1,163 @@
+package Tk::Font;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Font.pm#4 $
+require Tk::Widget;
+use strict;
+use Carp;
+use overload '""' => 'as_string';
+sub as_string { return ${$_[0]} }
+
+*MainWindow = \&Tk::Widget::MainWindow;
+
+foreach my $key (qw(actual metrics measure configure))
+ {
+ no strict 'refs';
+ *{$key} = sub { shift->Tk::font($key,@_) };
+ }
+
+Construct Tk::Widget 'Font';
+
+my @xfield = qw(foundry family weight slant swidth adstyle pixel
+ point xres yres space avgwidth registry encoding);
+my @tkfield = qw(family size weight slant underline overstrike);
+my %tkfield = map { $_ => "-$_" } @tkfield;
+
+sub _xonly { my $old = '*'; return $old }
+
+sub Pixel
+{
+ my $me = shift;
+ my $old = $me->configure('-size');
+ $old = '*' if ($old > 0);
+ if (@_)
+ {
+ $me->configure(-size => -$_[0]);
+ }
+ return $old;
+}
+
+sub Point
+{
+ my $me = shift;
+ my $old = 10*$me->configure('-size');
+ $old = '*' if ($old < 0);
+ if (@_)
+ {
+ $me->configure(-size => int($_[0]/10));
+ }
+ return $old;
+}
+
+foreach my $f (@tkfield,@xfield)
+ {
+ no strict 'refs';
+ my $sub = "\u$f";
+ unless (defined &{$sub})
+ {
+ my $key = $tkfield{$f};
+ if (defined $key)
+ {
+ *{$sub} = sub { shift->configure($key,@_) };
+ }
+ else
+ {
+ *{$sub} = \&_xonly;
+ }
+ }
+ }
+
+sub new
+{
+ my $pkg = shift;
+ my $w = shift;
+ my $me;
+ if (scalar(@_) == 1)
+ {
+ $me = $w->Tk::font('create',@_);
+ }
+ else
+ {
+ croak 'Odd number of args' if @_ & 1;
+ my %attr;
+ while (@_)
+ {
+ my $k = shift;
+ my $v = shift;
+ my $t = (substr($k,0,1) eq '-') ? $k : $tkfield{$k};
+ if (defined $t)
+ {
+ $attr{$t} = $v;
+ }
+ elsif ($k eq 'point')
+ {
+ $attr{'-size'} = -int($v/10+0.5);
+ }
+ elsif ($k eq 'pixel')
+ {
+ $attr{'-size'} = -$v;
+ }
+ else
+ {
+ carp "$k ignored" if $^W;
+ }
+ }
+ $me = $w->Tk::font('create',%attr);
+ }
+ return bless $me,$pkg;
+}
+
+sub Pattern
+{
+ my $me = shift;
+ my @str;
+ foreach my $f (@xfield)
+ {
+ my $meth = "\u$f";
+ my $str = $me->$meth();
+ if ($f eq 'family')
+ {
+ $str =~ s/(?:Times\s+New\s+Roman|New York)/Times/i;
+ $str =~ s/(?:Courier\s+New|Monaco)/Courier/i;
+ $str =~ s/(?:Arial|Geneva)/Helvetica/i;
+ }
+ elsif ($f eq 'slant')
+ {
+ $str = substr($str,0,1);
+ }
+ elsif ($f eq 'weight')
+ {
+ $str = 'medium' if ($str eq 'normal');
+ }
+ push(@str,$str);
+ }
+ return join('-', '', @str);
+}
+
+sub Name
+{
+ my $me = shift;
+ return $$me if (!wantarray || ($^O eq 'MSWin32'));
+ my $max = shift || 128;
+ my $w = $me->MainWindow;
+ my $d = $w->Display;
+ return $d->XListFonts($me->Pattern,$max);
+}
+
+sub Clone
+{
+ my $me = shift;
+ return ref($me)->new($me,$me->actual,@_);
+}
+
+sub ascent
+{
+ return shift->metrics('-ascent');
+}
+
+sub descent
+{
+ return shift->metrics('-descent');
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Frame.pm b/Master/tlpkg/tlperl/lib/Tk/Frame.pm
new file mode 100644
index 00000000000..a5716cdf9bd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Frame.pm
@@ -0,0 +1,378 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Frame;
+require Tk::Widget;
+require Tk::Derived;
+use AutoLoader;
+use strict qw(vars);
+use Carp;
+
+use base qw(Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Frame';
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $
+
+sub Tk_cmd { \&Tk::frame }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-colormap','-visual','-container')
+}
+
+sub Default
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ $cw->Delegates(DEFAULT => $widget);
+ $cw->ConfigSpecs(DEFAULT => [$widget]);
+ $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect
+ $cw->Advertise($name,$widget);
+}
+
+sub ConfigDelegate
+{
+ my ($cw,$name,@skip) = @_;
+ my $sw = $cw->Subwidget($name);
+ my $sc;
+ my %skip = ();
+ foreach $sc (@skip)
+ {
+ $skip{$sc} = 1;
+ }
+ foreach $sc ($sw->configure)
+ {
+ my (@info) = @$sc;
+ next if (@info == 2);
+ my $option = $info[0];
+ unless ($skip{$option})
+ {
+ $option =~ s/^-(.*)/-$name\u$1/;
+ $info[0] = Tk::Configure->new($sw,$info[0]);
+ pop(@info);
+ $cw->ConfigSpecs($option => \@info);
+ }
+ }
+}
+
+sub bind
+{my ($cw,@args) = @_;
+ $cw->Delegate('bind',@args);
+}
+
+sub menu
+{my ($cw,@args) = @_;
+ $cw->Delegate('menu',@args);
+}
+
+sub focus
+{my ($cw,@args) = @_;
+ $cw->Delegate('focus',@args);
+}
+
+#sub bindtags
+#{my ($cw,@args) = @_;
+# $cw->Delegate('bindtags',@args);
+#}
+
+sub selection
+{my ($cw,@args) = @_;
+ $cw->Delegate('selection',@args);
+}
+
+sub autoLabel { 1 }
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ if ($cw->autoLabel)
+ {
+ $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]);
+ $cw->labelPack([]) if grep /^-label\w+/, keys %$args;
+ }
+}
+
+sub Menubar
+{
+ my $frame = shift;
+ my $menu = $frame->cget('-menu');
+ if (defined $menu)
+ {
+ $menu->configure(@_) if @_;
+ }
+ else
+ {
+ $menu = $frame->Menu(-type => 'menubar',@_);
+ $frame->configure('-menu' => $menu);
+ }
+ $frame->Advertise('menubar' => $menu);
+ return $menu;
+}
+
+1;
+
+__END__
+
+sub labelPack
+{
+ my ($cw,$val) = @_;
+ my $w = $cw->Subwidget('label');
+ my @result = ();
+ if (@_ > 1)
+ {
+ if (defined($w) && !defined($val))
+ {
+ $w->packForget;
+ }
+ elsif (defined($val) && !defined ($w))
+ {
+ require Tk::Label;
+ $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
+ $cw->Advertise('label' => $w);
+ $cw->ConfigDelegate('label',qw(-text -textvariable));
+ }
+ if (defined($val) && defined($w))
+ {
+ my %pack = @$val;
+ unless (exists $pack{-side})
+ {
+ $pack{-side} = 'top' unless (exists $pack{-side});
+ }
+ unless (exists $pack{-fill})
+ {
+ $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
+ $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
+ }
+ unless (exists($pack{'-before'}) || exists($pack{'-after'}))
+ {
+ my $before = ($cw->packSlaves)[0];
+ $pack{'-before'} = $before if (defined $before);
+ }
+ $w->pack(%pack);
+ }
+ }
+ @result = $w->packInfo if (defined $w);
+ return (wantarray) ? @result : \@result;
+}
+
+sub labelVariable
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-labelVariable'};
+ if (@_ > 1 && defined $val)
+ {
+ $$var = $val;
+ $$val = '' unless (defined $$val);
+ my $w = $cw->Subwidget('label');
+ unless (defined $w)
+ {
+ $cw->labelPack([]);
+ $w = $cw->Subwidget('label');
+ }
+ $w->configure(-textvariable => $val);
+ }
+ return $$var;
+}
+
+sub label
+{
+ my ($cw,$val) = @_;
+ my $var = $cw->cget('-labelVariable');
+ if (@_ > 1 && defined $val)
+ {
+ if (!defined $var)
+ {
+ $var = \$cw->{Configure}{'-label'};
+ $cw->labelVariable($var);
+ }
+ $$var = $val;
+ }
+ return (defined $var) ? $$var : undef;;
+}
+
+sub queuePack
+{
+ my ($cw) = @_;
+ unless ($cw->{'pack_pending'})
+ {
+ $cw->{'pack_pending'} = 1;
+ $cw->afterIdle([$cw,'packscrollbars']);
+ }
+}
+
+sub sbset
+{
+ my ($cw,$sb,$ref,@args) = @_;
+ $sb->set(@args);
+ $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
+}
+
+sub freeze_on_map
+{
+ my ($w) = @_;
+ unless ($w->Tk::bind('Freeze','<Map>'))
+ {
+ $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
+ }
+ $w->AddBindTag('Freeze');
+}
+
+sub AddScrollbars
+{
+ require Tk::Scrollbar;
+ my ($cw,$w) = @_;
+ my $def = '';
+ my ($x,$y) = ('','');
+ my $s = 0;
+ my $c;
+ $cw->freeze_on_map;
+ foreach $c ($w->configure)
+ {
+ my $opt = $c->[0];
+ if ($opt eq '-yscrollcommand')
+ {
+ my $slice = Tk::Frame->new($cw,Name => 'ysbslice');
+ my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
+ my $size = $ysb->cget('-width');
+ my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
+ '-width' => $size, '-height' => $size);
+ $ysb->pack(-side => 'left', -fill => 'y');
+ $cw->Advertise('yscrollbar' => $ysb);
+ $cw->Advertise('corner' => $corner);
+ $cw->Advertise('ysbslice' => $slice);
+ $corner->{'before'} = $ysb->PathName;
+ $slice->{'before'} = $w->PathName;
+ $y = 'w';
+ $s = 1;
+ }
+ elsif ($opt eq '-xscrollcommand')
+ {
+ my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
+ $cw->Advertise('xscrollbar' => $xsb);
+ $xsb->{'before'} = $w->PathName;
+ $x = 's';
+ $s = 1;
+ }
+ }
+ if ($s)
+ {
+ $cw->Advertise('scrolled' => $w);
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
+ }
+}
+
+sub packscrollbars
+{
+ my ($cw) = @_;
+ my $opt = $cw->cget('-scrollbars');
+ my $slice = $cw->Subwidget('ysbslice');
+ my $xsb = $cw->Subwidget('xscrollbar');
+ my $corner = $cw->Subwidget('corner');
+ my $w = $cw->Subwidget('scrolled');
+ my $xside = (($opt =~ /n/) ? 'top' : 'bottom');
+ my $havex = 0;
+ my $havey = 0;
+ $opt =~ s/r//;
+ $cw->{'pack_pending'} = 0;
+ if (defined $slice)
+ {
+ my $reqy;
+ my $ysb = $cw->Subwidget('yscrollbar');
+ if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
+ {
+ my $yside = (($opt =~ /w/) ? 'left' : 'right');
+ $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
+ $havey = 1;
+ if ($reqy)
+ {
+ $w->configure(-yscrollcommand => ['set', $ysb]);
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
+ $slice->packForget;
+ }
+ $cw->{'packysb'} = $havey;
+ }
+ if (defined $xsb)
+ {
+ my $reqx;
+ if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
+ {
+ $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
+ $havex = 1;
+ if ($reqx)
+ {
+ $w->configure(-xscrollcommand => ['set', $xsb]);
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
+ $xsb->packForget;
+ }
+ $cw->{'packxsb'} = $havex;
+ }
+ if (defined $corner)
+ {
+ if ($havex && $havey && defined $corner->{'before'})
+ {
+ my $anchor = $opt;
+ $anchor =~ s/o//g;
+ $corner->configure(-height => $xsb->ReqHeight);
+ $corner->pack(-before => $corner->{'before'}, -side => $xside,
+ -anchor => $anchor, -fill => 'x');
+ }
+ else
+ {
+ $corner->packForget;
+ }
+ }
+}
+
+sub scrollbars
+{
+ my ($cw,$opt) = @_;
+ my $var = \$cw->{'-scrollbars'};
+ if (@_ > 1)
+ {
+ my $old = $$var;
+ if (!defined $old || $old ne $opt)
+ {
+ $$var = $opt;
+ $cw->queuePack;
+ }
+ }
+ return $$var;
+}
+
+sub FindMenu
+{
+ my ($w,$char) = @_;
+ my $child;
+ my $match;
+ foreach $child ($w->children)
+ {
+ next unless (ref $child);
+ $match = $child->FindMenu($char);
+ return $match if (defined $match);
+ }
+ return undef;
+}
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/HList.pm b/Master/tlpkg/tlperl/lib/Tk/HList.pm
new file mode 100644
index 00000000000..02792208243
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/HList.pm
@@ -0,0 +1,680 @@
+package Tk::HList;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'HList';
+sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) }
+
+bootstrap Tk::HList;
+
+sub Tk_cmd { \&Tk::hlist }
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ my @result = $package->SUPER::CreateArgs($parent,$args);
+ my $columns = delete $args->{-columns};
+ push(@result, '-columns' => $columns) if (defined $columns);
+ return @result;
+}
+
+Tk::Methods qw(add addchild anchor column
+ delete dragsite dropsite entrycget
+ entryconfigure geometryinfo indicator header hide item info
+ nearest see select selection show xview yview);
+
+use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
+ 'header' => [qw(configure cget create delete exists size)],
+ 'indicator' => [qw(configure cget create delete exists size)],
+ 'info' => [qw(anchor bbox children data dragsite
+ dropsite exists hidden item next parent prev
+ selection)],
+ 'item' => [qw(configure cget create delete exists)],
+ 'selection' => [qw(clear get includes set)],
+ 'anchor' => [qw(clear set)],
+ 'column' => [qw(width)],
+ 'hide' => [qw(entry)],
+ );
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
+ $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
+ $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ $mw->bind($class,'<Double-ButtonRelease-1>','NoOp');
+ $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
+ $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
+
+ $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
+
+ $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
+ $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
+ $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
+
+ $mw->bind($class,'<B1-Enter>','B1_Enter');
+
+ $mw->bind($class,'<Up>',['UpDown', 'prev']);
+ $mw->bind($class,'<Down>',['UpDown', 'next']);
+
+ $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']);
+ $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']);
+
+ $mw->bind($class,'<Left>', ['LeftRight', 'left']);
+ $mw->bind($class,'<Right>',['LeftRight', 'right']);
+
+ $mw->PriorNextBind($class);
+ $mw->MouseWheelBind($class);
+
+ $mw->bind($class,'<Return>', ['KeyboardActivate']);
+ $mw->bind($class,'<space>', ['KeyboardBrowse']);
+ $mw->bind($class,'<Home>', ['KeyboardHome']);
+ $mw->bind($class,'<End>', ['KeyboardEnd']);
+
+ $mw->YMouseWheelBind($class);
+ $mw->XMouseWheelBind($class);
+
+ return $class;
+}
+
+sub Control_ButtonRelease_1
+{
+}
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+ $w->ButtonRelease1($Ev);
+}
+
+sub Control_B1_Motion
+{
+}
+
+sub B1_Enter
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+}
+
+sub Button1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ $w->focus() if($w->cget('-takefocus'));
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+ # $w->Send_WaitDrag($Ev->y);
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ if (!defined($ent) || !length($ent))
+ {
+ $w->selectionClear;
+ $w->anchorClear;
+ return;
+ }
+
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if (@info)
+ {
+ die 'Assert' unless $info[0] eq $ent;
+ }
+ else
+ {
+ @info = $ent;
+ }
+
+ if (defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->{tixindicator} = $ent;
+ $w->Callback(-indicatorcmd => $ent, '<Arm>');
+ }
+ else
+ {
+ my $browse = 0;
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->selectionClear;
+ $w->anchorSet($ent);
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ $browse = 1;
+ }
+
+ if ($browse)
+ {
+ $w->Callback(-browsecmd => @info);
+ }
+ }
+}
+
+sub ShiftButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ my $to = $w->GetNearest($Ev->y, 1);
+
+ delete $w->{'shiftanchor'};
+ delete $w->{tixindicator};
+
+ return unless (defined($to) and length($to));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended' or $mode eq 'multiple')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $to);
+ }
+ else
+ {
+ $w->anchorSet($to);
+ $w->selectionClear;
+ $w->selectionSet($to);
+ }
+ }
+}
+
+sub GetNearest
+{
+ my ($w,$y,$undefafterend) = @_;
+ my $ent = $w->nearest($y);
+ if (defined $ent)
+ {
+ if ($undefafterend)
+ {
+ my $borderwidth = $w->cget('-borderwidth');
+ my $highlightthickness = $w->cget('-highlightthickness');
+ my $bottomy = ($w->infoBbox($ent))[3];
+ $bottomy += $borderwidth + $highlightthickness;
+ if ($w->header('exist', 0))
+ {
+ $bottomy += $w->header('height');
+ }
+ if ($y > $bottomy)
+ {
+ #print "$y > $bottomy\n";
+ return undef;
+ }
+ }
+ my $state = $w->entrycget($ent, '-state');
+ return $ent if (!defined($state) || $state ne 'disabled');
+ }
+ return undef;
+}
+
+sub ButtonRelease1
+{
+ my ($w, $Ev) = @_;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'dragdrop')
+ {
+# $w->Send_DoneDrag();
+ return;
+ }
+
+ my ($x, $y) = ($Ev->x, $Ev->y);
+ my $ent = $w->GetNearest($y, 1);
+
+ if (!defined($ent) and $mode eq 'single')
+ {
+ my $ent = $w->info('selection');
+ if (defined $ent)
+ {
+ $w->anchorSet($ent);
+ }
+ }
+ return unless (defined($ent) and length($ent));
+
+ if (exists $w->{tixindicator})
+ {
+ return unless delete($w->{tixindicator}) eq $ent;
+ my @info = $w->info('item',$Ev->x, $Ev->y);
+ if(defined($info[1]) && $info[1] eq 'indicator')
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Activate>');
+ }
+ else
+ {
+ $w->Callback(-indicatorcmd => $ent, '<Disarm>');
+ }
+ return;
+ }
+
+ if($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selectionSet($ent);
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->selectionSet($ent);
+ }
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub Button1Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+# $w->Send_StartDrag();
+ return;
+ }
+
+ my $ent;
+ if (defined $w->info('anchor'))
+ {
+ $ent = $w->GetNearest($Ev->y);
+ }
+ else
+ {
+ $ent = $w->GetNearest($Ev->y, 1);
+ }
+ return unless (defined($ent) and length($ent));
+
+ if(exists $w->{tixindicator})
+ {
+ my $event_type = $w->{tixindicator} eq $ent ? '<Arm>' : '<Disarm>';
+ $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type );
+ return;
+ }
+
+ if ($mode eq 'single')
+ {
+ $w->anchorSet($ent);
+ }
+ elsif ($mode eq 'multiple' || $mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if(defined $from)
+ {
+ $w->selectionClear;
+ $w->selectionSet($from, $ent);
+ }
+ else
+ {
+ $w->anchorSet($ent);
+ $w->selectionClear;
+ $w->selectionSet($ent);
+ }
+ }
+
+ if ($mode ne 'single')
+ {
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub Double1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ $w->anchorSet($ent)
+ unless(defined $w->info('anchor'));
+
+ $w->selectionSet($ent);
+
+ $w->Callback(-command => $ent);
+}
+
+sub CtrlButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->y, 1);
+
+ return unless (defined($ent) and length($ent));
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended')
+ {
+ $w->anchorSet($ent) unless( defined $w->info('anchor') );
+
+ if($w->select('includes', $ent))
+ {
+ $w->select('clear', $ent);
+ }
+ else
+ {
+ $w->selectionSet($ent);
+ }
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub UpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $done = 0;
+ my $anchor = $w->info('anchor');
+
+ delete $w->{'shiftanchor'};
+
+ unless( defined $anchor )
+ {
+ $anchor = ($w->info('children'))[0] || '';
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->entrycget($anchor, '-state') ne 'disabled')
+ {
+ # That's a good anchor
+ $done = 1;
+ }
+ else
+ {
+ # We search for the first non-disabled entry (downward)
+ $spec = 'next';
+ }
+ }
+
+ my $ent = $anchor;
+
+ # Find the prev/next non-disabled entry
+ #
+ while(!$done)
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( defined $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selection('set', $ent);
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub ShiftUpDown
+{
+ my $w = shift;
+ my $spec = shift;
+
+ my $mode = $w->cget('-selectmode');
+
+ return $w->UpDown($spec)
+ if($mode eq 'single' || $mode eq 'browse');
+
+ my $anchor = $w->info('anchor');
+
+ return $w->UpDown($spec) unless (defined($anchor) and length($anchor));
+
+ my $done = 0;
+
+ $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} );
+
+ my $ent = $w->{'shiftanchor'};
+
+ while( !$done )
+ {
+ $ent = $w->info($spec, $ent);
+ last unless( defined $ent );
+ next if( $w->entrycget($ent, '-state') eq 'disabled' );
+ next if( $w->info('hidden', $ent) );
+ last;
+ }
+
+ unless( $ent )
+ {
+ $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->selectionClear;
+ $w->selection('set', $anchor, $ent);
+ $w->see($ent);
+
+ $w->{'shiftanchor'} = $ent;
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub LeftRight
+{
+ my $w = shift;
+ my $spec = shift;
+
+ delete $w->{'shiftanchor'};
+
+ my $anchor = $w->info('anchor');
+
+ unless(defined $anchor)
+ {
+ $anchor = ($w->info('children'))[0] || '';
+ }
+
+ my $done = 0;
+ my $ent = $anchor;
+
+ while(!$done)
+ {
+ my $e = $ent;
+
+ if($spec eq 'left')
+ {
+ $ent = $w->info('parent', $e);
+
+ $ent = $w->info('prev', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+ else
+ {
+ $ent = ($w->info('children', $e))[0];
+
+ $ent = $w->info('next', $e)
+ unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
+ }
+
+ last unless( defined $ent );
+ last if($w->entrycget($ent, '-state') ne 'disabled');
+ }
+
+ unless( defined $ent )
+ {
+ $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit');
+ return;
+ }
+
+ $w->anchorSet($ent);
+ $w->see($ent);
+
+ if($w->cget('-selectmode') ne 'single')
+ {
+ $w->selectionClear;
+ $w->selectionSet($ent);
+
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub KeyboardHome
+{
+ my $w = shift;
+ $w->yview('moveto' => 0);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardEnd
+{
+ my $w = shift;
+ $w->yview('moveto' => 1);
+ $w->xview('moveto' => 0);
+}
+
+sub KeyboardActivate
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+
+ $w->Callback(-command => $anchor);
+}
+
+sub KeyboardBrowse
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless (defined($anchor) and length($anchor));
+
+ if ($w->indicatorExists($anchor))
+ {
+ $w->Callback(-indicatorcmd => $anchor);
+ }
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selectionClear;
+ $w->selectionSet($anchor);
+ }
+ $w->Callback(-browsecmd =>$anchor);
+}
+
+sub AutoScan
+{
+ my ($w,$x,$y) = @_;
+
+ return if ($w->cget('-selectmode') eq 'dragdrop');
+ if (@_ < 3)
+ {
+ my $Ev = $w->XEvent;
+ return unless defined $Ev;
+ $y = $Ev->y;
+ $x = $Ev->x;
+ }
+
+ if($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ }
+ elsif($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ }
+ elsif($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ }
+ elsif($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ }
+ else
+ {
+ return;
+ }
+ $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ]));
+ $w->Button1Motion;
+}
+
+sub children
+{
+ # Tix has core-tk window(s) which are not a widget(s)
+ # the generic code returns these as an "undef"
+ my $w = shift;
+ my @info = grep(defined($_),$w->winfo('children'));
+ @info;
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/IO.pm b/Master/tlpkg/tlperl/lib/Tk/IO.pm
new file mode 100644
index 00000000000..771e9f7103a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/IO.pm
@@ -0,0 +1,182 @@
+package Tk::IO;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $
+
+require 5.002;
+use Tk::Event qw($XS_VERSION);
+
+use Carp;
+use base qw(DynaLoader IO::Handle);
+
+bootstrap Tk::IO;
+
+my %fh2obj;
+my %obj2fh;
+
+sub new
+{
+ my ($package,%args) = @_;
+ # Do whatever IO::Handle does
+ my $fh = $package->SUPER::new;
+ %{*$fh} = (); # The hash is used for configure options
+ ${*$fh} = ''; # The scalar is used as the 'readable' buffer
+ @{*$fh} = (); # The array
+ $fh->configure(%args);
+ return $fh;
+}
+
+sub pending
+{
+ my $fh = shift;
+ return ${*$fh};
+}
+
+sub cget
+{
+ my ($fh,$key) = @_;
+ return ${*$fh}{$key};
+}
+
+sub configure
+{
+ my ($fh,%args) = @_;
+ my $key;
+ foreach $key (keys %args)
+ {
+ my $val = $args{$key};
+ $val = Tk::Callback->new($val) if ($key =~ /command$/);
+ ${*$fh}{$key} = $val;
+ }
+}
+
+sub killpg
+{
+ my ($fh,$sig) = @_;
+ my $pid = $fh->pid;
+ croak 'No child' unless (defined $pid);
+ kill($sig,-$pid);
+}
+
+sub kill
+{
+ my ($fh,$sig) = @_;
+ my $pid = $fh->pid;
+ croak 'No child' unless (defined $pid);
+ kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!";
+}
+
+sub readable
+{
+ my $fh = shift;
+ my $count = sysread($fh,${*$fh},1,length(${*$fh}));
+ if ($count < 0)
+ {
+ if (exists ${*$fh}{-errorcommand})
+ {
+ ${*$fh}{-errorcommand}->Call($!);
+ }
+ else
+ {
+ warn "Cannot read $fh:$!";
+ $fh->close;
+ }
+ }
+ elsif ($count)
+ {
+ if (exists ${*$fh}{-linecommand})
+ {
+ my $eol = index(${*$fh},"\n");
+ if ($eol >= 0)
+ {
+ my $line = substr(${*$fh},0,++$eol);
+ substr(${*$fh},0,$eol) = '';
+ ${*$fh}{-linecommand}->Call($line);
+ }
+ }
+ }
+ else
+ {
+ $fh->close;
+ }
+}
+
+sub pid
+{
+ my $fh = shift;
+ return ${*$fh}{-pid};
+}
+
+sub command
+{
+ my $fh = shift;
+ my $cmd = ${*$fh}{'-exec'};
+ return (wantarray) ? @$cmd : $cmd;
+}
+
+sub exec
+{
+ my $fh = shift;
+ my $pid = open($fh,'-|');
+ if ($pid)
+ {
+ ${*$fh} = '' unless (defined ${*$fh});
+ ${*$fh}{'-exec'} = [@_];
+ ${*$fh}{'-pid'} = $pid;
+ if (exists ${*$fh}{-linecommand})
+ {
+ my $w = ${*$fh}{-widget};
+ $w = 'Tk' unless (defined $w);
+ $w->fileevent($fh,'readable',[$fh,'readable']);
+ ${*$fh}{_readable} = $w;
+ }
+ else
+ {
+ croak Tk::Pretty::Pretty(\%{*$fh});
+ }
+ return $pid;
+ }
+ else
+ {
+ # make STDERR same as STDOUT here
+ setpgrp;
+ exec(@_) || die 'Cannot exec ',join(' ',@_),":$!";
+ }
+}
+
+sub wait
+{
+ my $fh = shift;
+ my $code;
+ my $ch = delete ${*$fh}{-childcommand};
+ ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift });
+ Tk::Event::DoOneEvent(0) until (defined $code);
+ if (defined $ch)
+ {
+ ${*$fh}{-childcommand} = $ch;
+ $ch->Call($code,$fh)
+ }
+ return $code;
+}
+
+sub close
+{
+ my $fh = shift;
+ my $code;
+ if (defined fileno($fh))
+ {
+ my $w = delete ${*$fh}{_readable};
+ $w->fileevent($fh,'readable','') if (defined $w);
+ $code = close($fh);
+ if (exists ${*$fh}{-childcommand})
+ {
+ ${*$fh}{-childcommand}->Call($?,$fh);
+ }
+ }
+ return $code;
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/IconList.pm b/Master/tlpkg/tlperl/lib/Tk/IconList.pm
new file mode 100644
index 00000000000..1972809ea2a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/IconList.pm
@@ -0,0 +1,712 @@
+# -*- perl -*-
+#
+# tkfbox.tcl --
+#
+# Implements the "TK" standard file selection dialog box. This
+# dialog box is used on the Unix platforms whenever the tk_strictMotif
+# flag is not set.
+#
+# The "TK" standard file selection dialog box is similar to the
+# file selection dialog box on Win95(TM). The user can navigate
+# the directories by clicking on the folder icons or by
+# selectinf the "Directory" option menu. The user can select
+# files by clicking on the file icons or by entering a filename
+# in the "Filename:" entry.
+#
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Translated to perk/Tk and modified by Slaven Rezic <slaven@rezic.de>.
+#
+
+#----------------------------------------------------------------------
+#
+# I C O N L I S T
+#
+# This is a pseudo-widget that implements the icon list inside the
+# tkFDialog dialog box.
+#
+#----------------------------------------------------------------------
+# tkIconList --
+#
+# Creates an IconList widget.
+#
+
+package Tk::IconList;
+require Tk::Frame;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/IconList.pm#7 $
+
+use Tk qw(Ev);
+use strict;
+use Carp;
+
+use base 'Tk::Frame';
+
+Construct Tk::Widget 'IconList';
+
+# tkIconList_Create --
+#
+# Creates an IconList widget by assembling a canvas widget and a
+# scrollbar widget. Sets all the bindings necessary for the IconList's
+# operations.
+#
+sub Populate {
+ my($w, $args) = @_;
+ $w->SUPER::Populate($args);
+
+ my $sbar = $w->Component('Scrollbar' => 'sbar',
+ -orient => 'horizontal',
+ -highlightthickness => 0,
+ -takefocus => 0,
+ );
+ # make sure that the size does not exceed handhelds' dimensions
+ my($sw,$sh) = ($w->screenwidth, $w->screenheight);
+ my $canvas = $w->Component('Canvas' => 'canvas',
+ -bd => 2,
+ -relief => 'sunken',
+ -width => ($sw > 420 ? 400 : $sw-20),
+ -height => ($sh > 160 ? 120 : $sh-40),
+ -takefocus => 1,
+ );
+ $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2);
+ $canvas->pack(-expand => 'yes', -fill => 'both');
+ $sbar->configure(-command => ['xview', $canvas]);
+ $canvas->configure(-xscrollcommand => ['set', $sbar]);
+
+ # Initializes the max icon/text width and height and other variables
+ $w->{'maxIW'} = 1;
+ $w->{'maxIH'} = 1;
+ $w->{'maxTW'} = 1;
+ $w->{'maxTH'} = 1;
+ $w->{'numItems'} = 0;
+#XXX curItem never used delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+ $w->{'selection'} = [];
+ $w->{'index,anchor'} = '';
+
+ # Creates the event bindings.
+ $canvas->Tk::bind('<Configure>', sub { $w->Arrange } );
+ $canvas->Tk::bind('<1>', [$w,'Btn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B1-Motion>', [$w,'Motion1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Control-B1-Motion>', 'NoOp');
+ $canvas->Tk::bind('<Shift-B1-Motion>', 'NoOp');
+ $canvas->Tk::bind('<Control-1>', [$w,'CtrlBtn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Shift-1>', [$w,'ShiftBtn1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Double-ButtonRelease-1>', [$w,'Double1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<Control-Double-ButtonRelease-1>', 'NoOp');
+ $canvas->Tk::bind('<Shift-Double-ButtonRelease-1>', 'NoOp');
+ $canvas->Tk::bind('<ButtonRelease-1>', [$w,'CancelRepeat']);
+ $canvas->Tk::bind('<B1-Leave>', [$w,'Leave1',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B1-Enter>', [$w,'CancelRepeat']);
+ $canvas->Tk::bind('<Up>', [$w,'UpDown', -1]);
+ $canvas->Tk::bind('<Down>', [$w,'UpDown', 1]);
+ $canvas->Tk::bind('<Left>', [$w,'LeftRight',-1]);
+ $canvas->Tk::bind('<Right>', [$w,'LeftRight', 1]);
+ $canvas->Tk::bind('<Return>', [$w,'ReturnKey']);
+ $canvas->Tk::bind('<KeyPress>', [$w,'KeyPress',Ev('A')]);
+ $canvas->Tk::bind('<Control-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<Meta-KeyPress>', 'NoOp');
+#XXX bad....
+# $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn });
+# $canvas->Tk::bind('<FocusOut>', sub { $w->FocusOut });
+
+ # additional bindings not in tkfbox.tcl
+ $canvas->Tk::bind('<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $canvas->Tk::bind('<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+ # Remove the standard Canvas bindings
+ $canvas->bindtags([$canvas, $canvas->toplevel, 'all']);
+ # ... and define some again
+ $canvas->Tk::bind('<Home>', ['xview','moveto',0]);
+ $canvas->Tk::bind('<End>', ['xview','moveto',1]);
+
+ $w->ConfigSpecs(-browsecmd =>
+ ['METHOD', 'browseCommand', 'BrowseCommand', undef],
+ -command =>
+ ['CALLBACK', 'command', 'Command', undef],
+ -font =>
+ ['PASSIVE', 'font', 'Font', undef],
+ -foreground =>
+ ['PASSIVE', 'foreground', 'Foreground', undef],
+ -fg => '-foreground',
+ -multiple =>
+ ['PASSIVE', 'multiple', 'Multiple', 0],
+ -selectmode =>
+ ['PASSIVE', 'selectMode', 'SelectMode', 'browse'],
+ -selectbackground =>
+ ['PASSIVE', 'selectBackground', 'Foreground', '#a0a0ff'],
+ );
+
+ $w;
+}
+
+# compatibility for old -browsecmd options
+sub browsecmd {
+ my $w = shift;
+ if (@_) {
+ $w->{Configure}{'-browsecmd'} = $_[0];
+ $w->bind('<<ListboxSelect>>' => $_[0]);
+ }
+ $w->{Configure}{'-browsecmd'};
+}
+
+sub Index {
+ my($w, $i) = @_;
+ if (!$w->{'list'}) { $w->{'list'} = [] }
+ if ($i =~ /^-?[0-9]+$/) {
+ if ($i < 0) {
+ $i = 0;
+ }
+ if ($i > @{ $w->{'list'} }) {
+ $i = @{ $w->{'list'} } - 1;
+ }
+ return $i;
+ } elsif ($i eq 'active') {
+ return $w->{'index,active'};
+ } elsif ($i eq 'anchor') {
+ return $w->{'index,anchor'};
+ } elsif ($i eq 'end') {
+ return @{ $w->{'list'} };
+ } elsif ($i =~ /@(-?[0-9]+),(-?[0-9]+)/) {
+ my($x, $y) = ($1, $2);
+ my $canvas = $w->Subwidget('canvas');
+ my $item = $canvas->find('closest', $x, $y);
+ if (defined $item) {
+ return $canvas->itemcget($item, '-tags')->[1];
+ } else {
+ return "";
+ }
+ } else {
+ croak "Unrecognized Index parameter `$i', use active, anchor, end, \@x,y, or x";
+ }
+}
+
+sub Selection {
+ my($w, $op, @args) = @_;
+ if ($op eq 'anchor') {
+ if (@args == 1) {
+ $w->{'index,anchor'} = $w->Index($args[0]);
+ } else {
+ return $w->{'index,anchor'};
+ }
+ } elsif ($op eq 'clear') {
+ my($first, $last);
+ if (@args == 2) {
+ ($first, $last) = @args;
+ } elsif (@args == 1) {
+ $first = $last = $args[0];
+ } else {
+ croak "wrong # args: should be Selection('clear', first, ?last?)"
+ }
+ $first = $w->Index($first);
+ $last = $w->Index($last);
+ if ($first > $last) {
+ ($first, $last) = ($last, $first);
+ }
+ my $ind = 0;
+ for my $item (@{ $w->{'selection'} }) {
+ if ($item >= $first) {
+ $first = $ind;
+ last;
+ }
+ $ind++; # XXX seems to be missing in the Tcl version
+ }
+ $ind = @{ $w->{'selection'} } - 1;
+ for(; $ind >= 0; $ind--) {
+ my $item = $w->{'selection'}->[$ind];
+ if ($item <= $last) {
+ $last = $ind;
+ last;
+ }
+ }
+ if ($first > $last) {
+ return;
+ }
+ splice @{ $w->{'selection'} }, $first, $last-$first+1;
+ $w->event('generate', '<<ListboxSelect>>');
+ $w->DrawSelection;
+ } elsif ($op eq 'includes') {
+ my $index;
+ for (@{ $w->{'selection'} }) {
+ if ($args[0] eq $_) {
+ return 1;
+ }
+ }
+ return 0;
+ } elsif ($op eq 'set') {
+ my($first, $last);
+ if (@args == 2) {
+ ($first, $last) = @args;
+ } elsif (@args == 1) {
+ $first = $last = $args[0];
+ } else {
+ croak "wrong # args: should be Selection('set', first, ?last?)";
+ }
+
+ $first = $w->Index($first);
+ $last = $w->Index($last);
+ if ($first > $last) {
+ ($first, $last) = ($last, $first);
+ }
+ for(my $i = $first; $i <= $last; $i++) {
+ push @{ $w->{'selection'} }, $i;
+ }
+ # lsort -integer -unique
+ my %sel = map { ($_ => 1) } @{ $w->{'selection'} };
+ @{ $w->{'selection'} } = sort { $a <=> $b } keys %sel;
+ $w->event('generate', '<<ListboxSelect>>');
+ $w->DrawSelection;
+ } else {
+ croak "Unrecognized Selection parameter `$op', use anchor, clear, includes, or set";
+ }
+}
+
+# XXX why lower case 's' here and upper in DrawSelection?
+sub Curselection {
+ my $w = shift;
+ @{ $w->{'selection'} };
+}
+
+sub DrawSelection {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->delete('selection');
+ my $selBg = $w->cget('-selectbackground');
+ for my $item (@{ $w->{'selection'} }) {
+ my $rTag = $w->{'list'}->[$item][2];
+ my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
+ my @bbox = $canvas->bbox($tTag);
+ # XXX don't hardcode colors
+ $canvas->createRectangle
+ (@bbox, -fill => $selBg, -outline => $selBg, -tags => 'selection');
+ }
+ $canvas->lower('selection');
+}
+
+# Returns the selected item
+#
+sub Get {
+ my($w, $item) = @_;
+ my $rTag = $w->{'list'}->[$item][2];
+ my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
+ $text;
+}
+
+
+# tkIconList_AutoScan --
+#
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The IconList window.
+#
+sub AutoScan {
+ my $w = shift;
+ return unless ($w->exists);
+ return if ($w->{'noScroll'});
+ my($x, $y);
+ $x = $Tk::x;
+ $y = $Tk::y;
+ my $canvas = $w->Subwidget('canvas');
+ if ($x >= $canvas->width) {
+ $canvas->xview('scroll', 1, 'units');
+ } elsif ($x < 0) {
+ $canvas->xview('scroll', -1, 'units');
+ } elsif ($y >= $canvas->height) {
+ # do nothing
+ } elsif ($y < 0) {
+ # do nothing
+ } else {
+ return;
+ }
+ $w->Motion1($x, $y);
+ $w->RepeatId($w->after(50, ['AutoScan', $w]));
+}
+
+# Deletes all the items inside the canvas subwidget and reset the IconList's
+# state.
+#
+sub DeleteAll {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->delete('all');
+ delete $w->{'selected'};
+ delete $w->{'rect'};
+ delete $w->{'list'};
+ delete $w->{'itemList'};
+ $w->{'maxIW'} = 1;
+ $w->{'maxIH'} = 1;
+ $w->{'maxTW'} = 1;
+ $w->{'maxTH'} = 1;
+ $w->{'numItems'} = 0;
+#XXX curItem never used delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+ $w->{'selection'} = [];
+ $w->{'index,anchor'} = '';
+ $w->Subwidget('sbar')->set(0.0, 1.0);
+ $canvas->xview('moveto', 0);
+}
+
+# Adds an icon into the IconList with the designated image and items
+#
+sub Add {
+ my($w, $image, @items) = @_;
+ my $canvas = $w->Subwidget('canvas');
+ my $font = $w->cget(-font);
+ my $fg = $w->cget(-foreground);
+ foreach my $text (@items) {
+ my $iTag = $canvas->createImage
+ (0, 0, -image => $image, -anchor => 'nw',
+ -tags => ['icon', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my $tTag = $canvas->createText
+ (0, 0, -text => $text, -anchor => 'nw',
+ (defined $fg ? (-fill => $fg) : ()),
+ (defined $font ? (-font => $font) : ()),
+ -tags => ['text', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my $rTag = $canvas->createRectangle
+ (0, 0, 0, 0,
+ -fill => undef,
+ -outline => undef,
+ -tags => ['rect', $w->{numItems}, 'item'.$w->{numItems}],
+ );
+ my(@b) = $canvas->bbox($iTag);
+ my $iW = $b[2] - $b[0];
+ my $iH = $b[3] - $b[1];
+ $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW);
+ $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH);
+ @b = $canvas->bbox($tTag);
+ my $tW = $b[2] - $b[0];
+ my $tH = $b[3] - $b[1];
+ $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW);
+ $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH);
+ push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH,
+ $w->{'numItems'}];
+ $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}];
+ $w->{'textList'}{$w->{'numItems'}} = lc($text);
+ ++$w->{'numItems'};
+ }
+}
+
+# Places the icons in a column-major arrangement.
+#
+sub Arrange {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ my $sbar = $w->Subwidget('sbar');
+ unless (exists $w->{'list'}) {
+ if (defined $canvas && Tk::Exists($canvas)) {
+ $w->{'noScroll'} = 1;
+ $sbar->configure(-command => sub { });
+ }
+ return;
+ }
+
+ my $W = $canvas->width;
+ my $H = $canvas->height;
+ my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
+ $pad = 2 if ($pad < 2);
+ $W -= $pad*2;
+ $H -= $pad*2;
+ my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8;
+ my $dy;
+ if ($w->{'maxTH'} > $w->{'maxIH'}) {
+ $dy = $w->{'maxTH'};
+ } else {
+ $dy = $w->{'maxIH'};
+ }
+ $dy += 2;
+ my $shift = $w->{'maxIW'} + 4;
+ my $x = $pad * 2;
+ my $y = $pad;
+ my $usedColumn = 0;
+ foreach my $sublist (@{ $w->{'list'} }) {
+ $usedColumn = 1;
+ my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist;
+ my $i_dy = ($dy - $iH) / 2;
+ my $t_dy = ($dy - $tH) / 2;
+ $canvas->coords($iTag, $x, $y + $i_dy);
+ $canvas->coords($tTag, $x + $shift, $y + $t_dy);
+ $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy);
+ $y += $dy;
+ if ($y + $dy > $H) {
+ $y = $pad;
+ $x += $dx;
+ $usedColumn = 0;
+ }
+ }
+ my $sW;
+ if ($usedColumn) {
+ $sW = $x + $dx;
+ } else {
+ $sW = $x;
+ }
+ if ($sW < $W) {
+ $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
+ $sbar->configure(-command => sub { });
+ $canvas->xview(moveto => 0);
+ $w->{'noScroll'} = 1;
+ } else {
+ $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
+ $sbar->configure(-command => ['xview', $canvas]);
+ $w->{'noScroll'} = 0;
+ }
+ $w->{'itemsPerColumn'} = int(($H - $pad) / $dy);
+ $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1);
+#XXX $w->Select($w->{'list'}[$w->{'curItem'}][2], 0)
+# if (exists $w->{'curItem'});
+ $w->DrawSelection; # missing in Tcl XXX
+}
+
+# Gets called when the user invokes the IconList (usually by double-clicking
+# or pressing the Return key).
+#
+sub Invoke {
+ my $w = shift;
+ $w->Callback(-command => $w->{'selected'}) if (@{ $w->{'selection'} });
+}
+
+# tkIconList_See --
+#
+# If the item is not (completely) visible, scroll the canvas so that
+# it becomes visible.
+sub See {
+ my($w, $rTag) = @_;
+ return if ($w->{'noScroll'});
+ return if ($rTag < 0 || $rTag >= @{ $w->{'list'} });
+ my $canvas = $w->Subwidget('canvas');
+ my(@sRegion) = @{ $canvas->cget('-scrollregion') };
+ return unless (@sRegion);
+ my(@bbox) = $canvas->bbox('item'.$rTag);
+ my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
+ my $x1 = $bbox[0];
+ my $x2 = $bbox[2];
+ $x1 -= $pad * 2;
+ $x2 -= $pad;
+ my $cW = $canvas->width - $pad * 2;
+ my $scrollW = $sRegion[2] - $sRegion[0] + 1;
+ my $dispX = int(($canvas->xview)[0] * $scrollW);
+ my $oldDispX = $dispX;
+ # check if out of the right edge
+ $dispX = $x2 - $cW if ($x2 - $dispX >= $cW);
+ # check if out of the left edge
+ $dispX = $x1 if ($x1 - $dispX < 0);
+ if ($oldDispX != $dispX) {
+ my $fraction = $dispX / $scrollW;
+ $canvas->xview('moveto', $fraction);
+ }
+}
+
+sub Btn1 {
+ my($w, $x, $y) = @_;
+
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ $x = int($canvas->canvasx($x));
+ $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+}
+
+sub CtrlBtn1 {
+ my($w, $x, $y) = @_;
+
+ if ($w->cget(-multiple)) {
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ my $x = int($canvas->canvasx($x));
+ my $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ if ($w->Selection('includes', $i)) {
+ $w->Selection('clear', $i);
+ } else {
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ }
+ }
+}
+
+sub ShiftBtn1 {
+ my($w, $x, $y) = @_;
+
+ if ($w->cget(-multiple)) {
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ my $x = int($canvas->canvasx($x));
+ my $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ my $a = $w->Index('anchor');
+ if ($a eq '') {
+ $a = $i;
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $a, $i);
+ }
+}
+
+# Gets called on button-1 motions
+#
+sub Motion1 {
+ my($w, $x, $y) = @_;
+ $Tk::x = $x;
+ $Tk::y = $y;
+ my $canvas = $w->Subwidget('canvas');
+ $canvas->CanvasFocus;
+ $x = int($canvas->canvasx($x));
+ $y = int($canvas->canvasy($y));
+ my $i = $w->Index('@'.$x.','.$y);
+ return if ($i eq '');
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+}
+
+sub Double1 {
+ my($w, $x, $y) = @_;
+ $w->Invoke if (@{ $w->{'selection'} });
+}
+
+sub ReturnKey {
+ my $w = shift;
+ $w->Invoke;
+}
+
+sub Leave1 {
+ my($w, $x, $y) = @_;
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $w->AutoScan;
+}
+
+sub FocusIn {
+ my $w = shift;
+ return unless (exists $w->{'list'});
+ if (@{ $w->{'selection'} }) {
+ $w->DrawSelection;
+ }
+}
+
+sub FocusOut {
+ my $w = shift;
+ $w->Selection('clear', 0, 'end');
+}
+
+# tkIconList_UpDown --
+#
+# Moves the active element up or down by one element
+#
+# Arguments:
+# w - The IconList widget.
+# amount - +1 to move down one item, -1 to move back one item.
+#
+sub UpDown {
+ my($w, $amount) = @_;
+ return unless (exists $w->{'list'});
+ my $i;
+ my(@curr) = $w->Curselection;
+ if (!@curr) {
+ $i = 0;
+ } else {
+ $i = $w->Index('anchor');
+ return if ($i eq '');
+ $i += $amount;
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ $w->See($i);
+}
+
+# tkIconList_LeftRight --
+#
+# Moves the active element left or right by one column
+#
+# Arguments:
+# w - The IconList widget.
+# amount - +1 to move right one column, -1 to move left one column.
+#
+sub LeftRight {
+ my($w, $amount) = @_;
+ return unless (exists $w->{'list'});
+ my $i;
+ my(@curr) = $w->Curselection;
+ if (!@curr) {
+ $i = 0;
+ } else {
+ $i = $w->Index('anchor');
+ return if ($i eq '');
+ $i += $amount*$w->{'itemsPerColumn'};
+ }
+ $w->Selection('clear', 0, 'end');
+ $w->Selection('set', $i);
+ $w->Selection('anchor', $i);
+ $w->See($i);
+}
+
+#----------------------------------------------------------------------
+# Accelerator key bindings
+#----------------------------------------------------------------------
+# tkIconList_KeyPress --
+#
+# Gets called when user enters an arbitrary key in the listbox.
+#
+sub KeyPress {
+ my($w, $key) = @_;
+ $w->{'_ILAccel'} .= $key;
+ $w->Goto($w->{'_ILAccel'});
+ eval {
+ $w->afterCancel($w->{'_ILAccel_afterid'});
+ };
+ $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]);
+}
+
+sub Goto {
+ my($w, $text) = @_;
+ return unless (exists $w->{'list'});
+ return if (not defined $text or $text eq '');
+#XXX curItem never used my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'});
+ my $start = 0;
+ $text = lc($text);
+ my $theIndex = -1;
+ my $less = 0;
+ my $len = length($text);
+ my $i = $start;
+ # Search forward until we find a filename whose prefix is an exact match
+ # with $text
+ while (1) {
+ my $sub = substr($w->{'textList'}{$i}, 0, $len);
+ if ($text eq $sub) {
+ $theIndex = $i;
+ last;
+ }
+ ++$i;
+ $i = 0 if ($i == $w->{'numItems'});
+ last if ($i == $start);
+ }
+ if ($theIndex > -1) {
+ $w->Selection(qw(clear 0 end));
+ $w->Selection('set', $theIndex);
+ $w->Selection('anchor', $theIndex);
+ $w->See($theIndex);
+ }
+}
+
+sub Reset {
+ my $w = shift;
+ undef $w->{'_ILAccel'};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Image.pm b/Master/tlpkg/tlperl/lib/Tk/Image.pm
new file mode 100644
index 00000000000..0f41c387fc2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Image.pm
@@ -0,0 +1,74 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Image;
+
+# This module does for images what Tk::Widget does for widgets:
+# provides a base class for them to inherit from.
+require DynaLoader;
+
+use base qw(DynaLoader Tk); # but are they ?
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ $package->InitClass($widget);
+ my $leaf = $package->Tk_image;
+ my $obj = $widget->Tk::image('create',$leaf,@_);
+ $obj = $widget->_object($obj) unless (ref $obj);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+require Tk::Submethods;
+
+Direct Tk::Submethods ('image' => [qw(delete width height type)]);
+
+sub Tk::Widget::imageNames
+{
+ my $w = shift;
+ $w->image('names',@_);
+}
+
+sub Tk::Widget::imageTypes
+{
+ my $w = shift;
+ map("\u$_",$w->image('types',@_));
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ *{"Tk::Widget::$name"} = sub { $class->new(@_) };
+}
+
+# This is here to prevent AUTOLOAD trying to find it.
+sub DESTROY
+{
+ my $i = shift;
+ # maybe do image delete ???
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm
new file mode 100644
index 00000000000..85c6c11a76c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ItemStyle.pm
@@ -0,0 +1,38 @@
+package Tk::ItemStyle;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/ItemStyle.pm#4 $
+
+require Tk;
+use base qw(Tk);
+require Tk::Widget;
+Construct Tk::Widget 'ItemStyle';
+
+Tk::Methods ('delete');
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ my $type = shift;
+ my %args = @_;
+ $args{'-refwindow'} = $widget unless exists $args{'-refwindow'};
+ $package->InitClass($widget);
+ my $obj = $widget->itemstyle($type, %args);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/JPEG.pm b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm
new file mode 100644
index 00000000000..9e0ef771f77
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/JPEG.pm
@@ -0,0 +1,50 @@
+package Tk::JPEG;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #2$ =~ /\D(\d+)\s*$/;
+use Tk 800.015;
+require Tk::Image;
+require Tk::Photo;
+require DynaLoader;
+
+use vars qw($VERSION $XS_VERSION);
+
+@ISA = qw(DynaLoader);
+
+$XS_VERSION = $Tk::VERSION;
+bootstrap Tk::JPEG;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::JPEG - JPEG loader for Tk::Photo
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::JPEG;
+
+ my $image = $widget->Photo('-format' => 'jpeg', -file => 'something.jpg');
+
+
+=head1 DESCRIPTION
+
+This is an extension for Tk800.015 and later which supplies
+JPEG format loader for Photo image type.
+
+This version also works with Tk804 series.
+
+JPEG access is via release 5 of the The Independent JPEG Group's (IJG)
+free JPEG software.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm
new file mode 100644
index 00000000000..64cb392fa8c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/LabEntry.pm
@@ -0,0 +1,31 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::LabEntry;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/LabEntry.pm#6 $
+
+use base qw(Tk::Frame);
+use Tk::widgets qw(Frame Label Entry);
+
+Construct Tk::Widget 'LabEntry';
+
+sub Populate
+{
+ require Tk::Entry;
+ # LabeledEntry constructor.
+ #
+ my($cw, $args) = @_;
+ $cw->SUPER::Populate($args);
+ # Advertised subwidgets: entry.
+ my $e = $cw->Entry();
+ $e->pack('-expand' => 1, '-fill' => 'both');
+ $cw->Advertise('entry' => $e );
+ $cw->ConfigSpecs(DEFAULT => [$e]);
+ $cw->Delegates(DEFAULT => $e);
+ $cw->AddScrollbars($e) if (exists $args->{-scrollbars});
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm
new file mode 100644
index 00000000000..6fcab1acc56
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/LabFrame.pm
@@ -0,0 +1,138 @@
+#
+# Labeled frame. Derives from Tk::Frame, but intercepts the labeling
+# part.
+
+package Tk::LabFrame;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $
+
+use Tk;
+use base qw(Tk::Frame);
+Tk::Widget->Construct('LabFrame');
+
+sub autoLabel { 0 }
+
+sub Populate {
+ my ($cw, $args) = @_;
+
+ $cw->{m_geoMgr} = "";
+
+ my $border = $cw->Component(
+ Frame => 'border',
+ -relief => 'groove',
+ -bd => 2,
+ );
+
+ my $pad = $border->Frame;
+ $cw->Advertise(pad => $pad);
+
+ my $frame = $border->Frame;
+ $cw->Advertise(frame => $frame);
+
+ my $label = $cw->Component(Label => 'label');
+
+ $cw->SUPER::Populate($args);
+
+ $cw->Delegates(DEFAULT => $frame);
+ $cw->ConfigSpecs(
+ -background => [[qw/SELF ADVERTISED/],
+ qw/background Background/],
+ -borderwidth => [$border, qw/borderWidth Border 2/],
+ -font => [$label, qw/font Font/],
+ -foreground => [$label, qw/foreground Foreground black/],
+ -label => [{-text => $label}, qw/label Label/],
+ -labelside => [qw/METHOD labelSide LabelSide acrosstop/],
+ -labelvariable => [{-textvariable => $label}],
+ -relief => [$border, qw/relief Relief groove/],
+ DEFAULT => [$frame]
+ );
+ return $cw;
+}
+
+use Tk::Submethods(
+ form => [qw/check forget grid info slaves/],
+ grid => [qw/bbox columnconfigure configure forget info location
+ propagate rowconfigure remove size slaves/],
+ pack => [qw/forget info propagate slaves/],
+ place => [qw/forget info slaves/]
+);
+
+sub labelside {
+ my ($cw, $side) = @_;
+ return $cw->{Configure}{-labelside} unless $side;
+
+ my $border = $cw->Subwidget('border');
+ my $pad = $cw->Subwidget('pad');
+ my $frame = $cw->Subwidget('frame');
+ my $label = $cw->Subwidget('label');
+
+ ## packForget/formForget as appropriate
+ foreach ($border, $label, $pad, $frame) {
+ $_->formForget if $cw->{m_geoMgr} eq "form";
+ $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped);
+ }
+
+ if ($side eq "acrosstop") {
+
+ my $y = $label->reqheight / 2;
+ my $ph = $y - ($border->cget(-bd));
+ $ph = 0 if $ph < 0;
+
+ $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/);
+ $border->form(-top => $y,
+ qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/);
+ $pad->form(-bottom => $ph,
+ qw/-top 0 -left 0 -right -1/);
+ $frame->form(-top => $pad,
+ qw/-bottom -1 -left 0 -right -1 -fill both/);
+ $cw->{m_geoMgr} = "form";
+
+ } else {
+
+ $label->pack(-side => $side);
+ $frame->pack(-expand => 1, -fill => 'both');
+ $border->pack(-side => $side, -expand => 1, -fill => 'both');
+ $cw->{m_geoMgr} = "pack";
+ }
+}
+
+sub form {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:slaves)$/);
+ $cw->SUPER::form(@_);
+}
+
+sub grid {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~
+ /^(?:bbox
+ |columnconfigure
+ |location
+ |propagate
+ |rowconfigure
+ |size
+ |slaves)
+ $/x);
+ $cw->SUPER::grid(@_);
+}
+
+
+sub pack {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:propagate|slaves)$/);
+ $cw->SUPER::pack(@_);
+}
+
+sub place {
+ my $cw = shift;
+ $cw = $cw->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:slaves)$/);
+ $cw->SUPER::place(@_);
+}
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm
new file mode 100644
index 00000000000..69e07b12f01
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/LabRadio.pm
@@ -0,0 +1,63 @@
+# Class LabeledRadiobutton
+
+package Tk::LabRadiobutton;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/LabRadio.pm#4 $
+
+require Tk::Frame;
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'LabRadiobutton';
+
+
+# Although there is no fundamental reason why -radiobuttons
+# should be fixed at create time converting to METHOD form
+# is extra work an this can serve as an example of CreateArgs
+# checking.
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ $parent->BackTrace("Must specify -radiobuttons for $package")
+ unless (defined $args->{'-radiobuttons'});
+ return $package->SUPER::CreateArgs($parent,$args);
+}
+
+sub Populate
+{
+ require Tk::Radiobutton;
+
+ my ($cw,$args) = @_;
+ $cw->SUPER::Populate($args);
+
+ # LabeledRadiobutton(s) constructor.
+ #
+ # Advertised subwidgets: the name(s) of your radiobutton(s).
+
+
+
+ my (@widgets) = ();
+
+ my $rl;
+ foreach $rl (@{$args->{'-radiobuttons'}})
+ {
+ my $r = $cw->Component( Radiobutton => $rl,
+ -text => $rl,
+ -value => $rl );
+ $r->pack(-side => 'left', -expand => 1, -fill => 'both');
+ push(@widgets,$r);
+ $cw->{Configure}{-value} = $rl;
+ }
+
+ $cw->BackTrace('No buttons') unless (@widgets);
+
+ $cw->ConfigSpecs('-variable' => [ \@widgets, undef, undef, \$cw->{Configure}{-value} ],
+ '-radiobuttons' => [ 'PASSIVE', undef, undef, undef ],
+ '-value' => [ 'PASSIVE', undef, undef, $cw->{Configure}{-value} ],
+ 'DEFAULT' => [ \@widgets ]
+ );
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Label.pm b/Master/tlpkg/tlperl/lib/Tk/Label.pm
new file mode 100644
index 00000000000..ebea1741c2f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Label.pm
@@ -0,0 +1,21 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::Label;
+require Tk;
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Label';
+
+sub Tk_cmd { \&Tk::label }
+
+1;
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm
new file mode 100644
index 00000000000..14c577b5e35
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Labelframe.pm
@@ -0,0 +1,16 @@
+package Tk::Labelframe;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #2 $ =~ /#(\d+)/;
+
+# New widget which is a kind of Frame with a label ...
+
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Labelframe';
+
+sub Tk_cmd { \&Tk::labelframe }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Listbox.pm b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm
new file mode 100644
index 00000000000..249a8eed7f4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Listbox.pm
@@ -0,0 +1,910 @@
+# Converted from listbox.tcl --
+#
+# This file defines the default bindings for Tk listbox widgets.
+#
+# @(#) listbox.tcl 1.7 94/12/17 16:05:18
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Modifications from standard Listbox.pm
+# --------------------------------------
+# 27-JAN-2001 Alasdair Allan
+# Modified for local use by adding tied scalar and arrays
+# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND
+# 31-JAN-2001 Alasdair Allan
+# Made changes suggested by Tim Jenness
+# 03-FEB-2001 Alasdair Allan
+# Modified STORE for tied scalars to clear and select elements
+# 06-FEB-2001 Alasdair Allan
+# Added POD documentation for tied listbox
+# 13-FEB-2001 Alasdair Allan
+# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays
+# 14-FEB-2001 Alasdair Allan
+# Implemented SPLICE for tied arrays, all tied functionality in place
+# 16-FEB-2001 Alasdair Allan
+# Tweak to STORE interface for tied scalars
+# 23-FEB-2001 Alasdair Allan
+# Added flag to FETCH for tied scalars, modified to return hashes
+# 24-FEB-2001 Alasdair Allan
+# Updated Pod documentation
+#
+
+package Tk::Listbox;
+
+use vars qw($VERSION @Selection $Prev);
+use strict;
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+use Tk::Clipboard ();
+use AutoLoader;
+
+use base qw(Tk::Clipboard Tk::Widget);
+
+Construct Tk::Widget 'Listbox';
+
+bootstrap Tk::Listbox;
+
+sub Tk_cmd { \&Tk::listbox }
+
+Tk::Methods('activate','bbox','curselection','delete','get','index',
+ 'insert','itemcget','itemconfigure','nearest','scan','see',
+ 'selection','size','xview','yview');
+
+use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
+ 'scan' => [qw(mark dragto)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ );
+
+*Getselected = \&getSelected;
+
+sub clipEvents
+{
+ return qw[Copy];
+}
+
+sub BalloonInfo
+{
+ my ($listbox,$balloon,$X,$Y,@opt) = @_;
+ my $e = $listbox->XEvent;
+ return if !$e;
+ my $index = $listbox->index('@' . $e->x . ',' . $e->y);
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$listbox);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
+ {
+ $balloon->Subclient($index);
+ if (defined $info->[$index])
+ {
+ return $info->[$index];
+ }
+ return '';
+ }
+ return $info;
+ }
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+ # Standard Motif bindings:
+ $mw->bind($class,'<1>',[sub {
+ my $w = shift;
+ if (Tk::Exists($w)) {
+ $w->BeginSelect(@_);
+ }
+ }, Ev('index',Ev('@'))]);
+ $mw->bind($class, '<Double-1>' => \&Tk::NoOp);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ ;
+ $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Up>',['UpDown',-1]);
+ $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
+ $mw->bind($class,'<Down>',['UpDown',1]);
+ $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
+
+ $mw->XscrollBind($class);
+ $mw->bind($class,'<Prior>', sub {
+ my $w = shift;
+ $w->yview('scroll',-1,'pages');
+ $w->activate('@0,0');
+ });
+ $mw->bind($class,'<Next>', sub {
+ my $w = shift;
+ $w->yview('scroll',1,'pages');
+ $w->activate('@0,0');
+ });
+ $mw->bind($class,'<Control-Prior>', ['xview', 'scroll', -1, 'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview', 'scroll', 1, 'pages']);
+ # <Home> and <End> defined in XscrollBind
+ $mw->bind($class,'<Control-Home>','Cntrl_Home');
+ ;
+ $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
+ $mw->bind($class,'<Control-End>','Cntrl_End');
+ ;
+ $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
+ # XXX What about <<Copy>>? Already handled in Tk::Clipboard?
+ # $class->clipboardOperations($mw,'Copy');
+ $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Escape>','Cancel');
+ $mw->bind($class,'<Control-slash>','SelectAll');
+ $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
+ ;
+ # Additional Tk bindings that aren't part of the Motif look and feel:
+ $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+
+ $mw->MouseWheelBind($class); # XXX Both needed?
+ $mw->YMouseWheelBind($class);
+ return $class;
+}
+
+1;
+__END__
+
+sub TIEARRAY {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+
+
+sub TIESCALAR {
+ my ( $class, $obj, %options ) = @_;
+ return bless {
+ OBJECT => \$obj,
+ OPTION => \%options }, $class;
+}
+
+# FETCH
+# -----
+# Return either the full contents or only the selected items in the
+# box depending on whether we tied it to an array or scalar respectively
+sub FETCH {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # Define the return variable
+ my $result;
+
+ # Check whether we are have a tied array or scalar quantity
+ if ( @_ ) {
+ my $i = shift;
+ # The Tk:: Listbox has been tied to an array, we are returning
+ # an array list of the current items in the Listbox
+ $result = $self->get($i);
+ } else {
+ # The Tk::Listbox has been tied to a scalar, we are returning a
+ # reference to an array or hash containing the currently selected items
+ my ( @array, %hash );
+
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ $result = [$self->curselection];
+ } elsif ( $options{ReturnType} eq "element" ) {
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $selection ( $self->curselection ) {
+ %hash = ( %hash, $selection => $self->get($selection)); }
+ $result = \%hash;
+ }
+ } else {
+ # return elements (default)
+ foreach my $selection ( $self->curselection ) {
+ push(@array,$self->get($selection)); }
+ $result = \@array;
+ }
+ }
+ return $result;
+}
+
+# FETCHSIZE
+# ---------
+# Return the number of elements in the Listbox when tied to an array
+sub FETCHSIZE {
+ my $class = shift;
+ return ${$class->{OBJECT}}->size();
+}
+
+# STORE
+# -----
+# If tied to an array we will modify the Listbox contents, while if tied
+# to a scalar we will select and clear elements.
+sub STORE {
+
+ if ( scalar(@_) == 2 ) {
+ # we have a tied scalar
+ my ( $class, $selected ) = @_;
+ my $self = ${$class->{OBJECT}};
+ my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
+
+ # clear currently selected elements
+ $self->selectionClear(0,'end');
+
+ # set selected elements
+ if ( defined $options{ReturnType} ) {
+
+ # THREE-WAY SWITCH
+ if ( $options{ReturnType} eq "index" ) {
+ for ( my $i=0; $i < scalar(@$selected) ; $i++ ) {
+ for ( my $j=0; $j < $self->size() ; $j++ ) {
+ if( $j == $$selected[$i] ) {
+ $self->selectionSet($j); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "element" ) {
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ } elsif ( $options{ReturnType} eq "both" ) {
+ foreach my $key ( keys %$selected ) {
+ $self->selectionSet($key)
+ if $$selected{$key} eq $self->get($key);
+ }
+ }
+ } else {
+ # return elements (default)
+ for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
+ for ( my $l=0; $l < $self->size() ; $l++ ) {
+ if( $self->get($l) eq $$selected[$k] ) {
+ $self->selectionSet($l); last; }
+ }
+ }
+ }
+
+ } else {
+ # we have a tied array
+ my ( $class, $index, $value ) = @_;
+ my $self = ${$class->{OBJECT}};
+
+ # check size of current contents list
+ my $sizeof = $self->size();
+
+ if ( $index <= $sizeof ) {
+ # Change a current listbox entry
+ $self->delete($index);
+ $self->insert($index, $value);
+ } else {
+ # Add a new value
+ if ( defined $index ) {
+ $self->insert($index, $value);
+ } else {
+ $self->insert("end", $value);
+ }
+ }
+ }
+}
+
+# CLEAR
+# -----
+# Empty the Listbox of contents if tied to an array
+sub CLEAR {
+ my $class = shift;
+ ${$class->{OBJECT}}->delete(0, 'end');
+}
+
+# EXTEND
+# ------
+# Do nothing and be happy about it
+sub EXTEND { }
+
+# PUSH
+# ----
+# Append elements onto the Listbox contents
+sub PUSH {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert('end', @list);
+}
+
+# POP
+# ---
+# Remove last element of the array and return it
+sub POP {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get('end');
+ ${$class->{OBJECT}}->delete('end');
+ return $value;
+}
+
+# SHIFT
+# -----
+# Removes the first element and returns it
+sub SHIFT {
+ my $class = shift;
+
+ my $value = ${$class->{OBJECT}}->get(0);
+ ${$class->{OBJECT}}->delete(0);
+ return $value
+}
+
+# UNSHIFT
+# -------
+# Insert elements at the beginning of the Listbox
+sub UNSHIFT {
+ my ( $class, @list ) = @_;
+ ${$class->{OBJECT}}->insert(0, @list);
+}
+
+# DELETE
+# ------
+# Delete element at specified index
+sub DELETE {
+ my ( $class, @list ) = @_;
+
+ my $value = ${$class->{OBJECT}}->get(@list);
+ ${$class->{OBJECT}}->delete(@list);
+ return $value;
+}
+
+# EXISTS
+# ------
+# Returns true if the index exist, and undef if not
+sub EXISTS {
+ my ( $class, $index ) = @_;
+ return undef unless ${$class->{OBJECT}}->get($index);
+}
+
+# SPLICE
+# ------
+# Performs equivalent of splice on the listbox contents
+sub SPLICE {
+ my $class = shift;
+
+ my $self = ${$class->{OBJECT}};
+
+ # check for arguments
+ my @elements;
+ if ( scalar(@_) == 0 ) {
+ # none
+ @elements = $self->get(0,'end');
+ $self->delete(0,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];;
+
+ } elsif ( scalar(@_) == 1 ) {
+ # $offset
+ my ( $offset ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,'end');
+ $self->delete($start,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,'end');
+ $self->delete($offset,'end');
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } elsif ( scalar(@_) == 2 ) {
+ # $offset and $length
+ my ( $offset, $length ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+
+ } else {
+ # $offset, $length and @list
+ my ( $offset, $length, @list ) = @_;
+ if ( $offset < 0 ) {
+ my $start = $self->size() + $offset;
+ my $end = $self->size() + $offset + $length - 1;
+ if ( $start > 0 ) {
+ @elements = $self->get($start,$end);
+ $self->delete($start,$end);
+ $self->insert($start,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ } else {
+ return undef;
+ }
+ } else {
+ @elements = $self->get($offset,$offset+$length-1);
+ $self->delete($offset,$offset+$length-1);
+ $self->insert($offset,@list);
+ return wantarray ? @elements : $elements[scalar(@elements)-1];
+ }
+ }
+}
+
+# ----
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters a listbox
+# widget or a listbox widget receives the input focus. It creates
+# all of the class bindings for listboxes.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+
+sub xyIndex
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ return $w->index($Ev->xy);
+}
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat;
+ $w->activate($Ev->xy);
+}
+
+
+sub Cntrl_Home
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate(0);
+ $w->see(0);
+ $w->selectionClear(0,'end');
+ $w->selectionSet(0);
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+
+sub Cntrl_End
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate('end');
+ $w->see('end');
+ $w->selectionClear(0,'end');
+ $w->selectionSet('end');
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+
+sub Cntrl_backslash
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if ($w->cget('-selectmode') ne 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses. It begins
+# the process of making a selection in the listbox. Its exact behavior
+# depends on the selection mode currently in effect for the listbox;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginSelect
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'multiple')
+ {
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+ else
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ @Selection = ();
+ $Prev = $el
+ }
+ $w->focus if ($w->cget('-takefocus'));
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down. It may move or extend the selection, depending
+# on the listbox's selection mode.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element under the pointer (must be a number).
+sub Motion
+{
+ my $w = shift;
+ my $el = shift;
+ if (defined($Prev) && $el == $Prev)
+ {
+ return;
+ }
+ my $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ my $i = $Prev;
+ if (!defined $i || $i eq '')
+ {
+ $i = $el;
+ $w->selectionSet($el);
+ }
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionSet('anchor',$el)
+ }
+ else
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionClear('anchor',$el)
+ }
+ if (!@Selection)
+ {
+ @Selection = $w->curselection;
+ }
+ while ($i < $el && $i < $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i++
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i--
+ }
+ $Prev = $el;
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses. It
+# begins the process of extending a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginExtend
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ else
+ {
+ # No selection yet; simulate the begin-select operation.
+ $w->BeginSelect($el);
+ }
+}
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses. It
+# begins the process of toggling a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginToggle
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended')
+ {
+ @Selection = $w->curselection();
+ $Prev = $el;
+ $w->selectionAnchor($el);
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+# y - The y-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ return if !Tk::Exists($w);
+ my $x = shift;
+ my $y = shift;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll',1,'units')
+ }
+ elsif ($y < 0)
+ {
+ $w->yview('scroll',-1,'units')
+ }
+ elsif ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->Motion($w->index("@" . $x . ',' . $y));
+ $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
+}
+# UpDown --
+#
+# Moves the location cursor (active element) up or down by one element,
+# and changes the selection if we're in browse or extended selection
+# mode.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub UpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+ elsif ($mode eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $Prev = $w->index('active');
+ @Selection = ();
+ $w->eventGenerate("<<ListboxSelect>>");
+ }
+}
+# ExtendUpDown --
+#
+# Does nothing unless we're in extended selection mode; in this
+# case it moves the location cursor (active element) up or down by
+# one element, and extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub ExtendUpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ if ($w->cget('-selectmode') ne 'extended')
+ {
+ return;
+ }
+ my $active = $w->index('active');
+ if (!@Selection)
+ {
+ $w->selectionSet($active);
+ @Selection = $w->curselection;
+ }
+ $w->activate($active + $amount);
+ $w->see('active');
+ $w->Motion($w->index('active'))
+}
+# DataExtend
+#
+# This procedure is called for key-presses such as Shift-KEndData.
+# If the selection mode isn't multiple or extend then it does nothing.
+# Otherwise it moves the active element to el and, if we're in
+# extended mode, extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# el - An integer element number.
+sub DataExtend
+{
+ my $w = shift;
+ my $el = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'extended')
+ {
+ $w->activate($el);
+ $w->see($el);
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->activate($el);
+ $w->see($el)
+ }
+}
+# Cancel
+#
+# This procedure is invoked to cancel an extended selection in
+# progress. If there is an extended selection in progress, it
+# restores all of the items between the active one and the anchor
+# to their previous selection state.
+#
+# Arguments:
+# w - The listbox widget.
+sub Cancel
+{
+ my $w = shift;
+ if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
+ {
+ return;
+ }
+ my $first = $w->index('anchor');
+ my $last = $Prev;
+ if ($first > $last)
+ {
+ ($first, $last) = ($last, $first);
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch(\@Selection,$first) >= 0)
+ {
+ $w->selectionSet($first)
+ }
+ $first++
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the active element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w - The listbox widget.
+sub SelectAll
+{
+ my $w = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ else
+ {
+ $w->selectionSet(0,'end')
+ }
+ $w->eventGenerate("<<ListboxSelect>>");
+}
+
+# Perl/Tk extensions:
+sub SetList
+{
+ my $w = shift;
+ $w->delete(0,'end');
+ $w->insert('end',@_);
+}
+
+sub deleteSelected
+{
+ my $w = shift;
+ my $i;
+ foreach $i (reverse $w->curselection)
+ {
+ $w->delete($i);
+ }
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ my $index = $w->index('active') || $w->index($w->XEvent->xy);
+ my $str;
+ eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
+ return if $@;
+ foreach (split("\n",$str))
+ {
+ $w->insert($index++,$_);
+ }
+}
+
+sub getSelected
+{
+ my ($w) = @_;
+ my $i;
+ my (@result) = ();
+ foreach $i ($w->curselection)
+ {
+ push(@result,$w->get($i));
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/MMtry.pm b/Master/tlpkg/tlperl/lib/Tk/MMtry.pm
new file mode 100644
index 00000000000..3ef2f8868ab
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/MMtry.pm
@@ -0,0 +1,54 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::MMtry;
+use Config;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+@EXPORT = qw(try_compile try_run);
+use strict;
+use File::Basename;
+use File::Spec;
+
+my $stderr_too = ($^O eq 'MSWin32') ? '' : '2>&1';
+
+sub try_compile
+{
+ my ($file,$inc,$lib) = @_;
+ $inc = [] unless $inc;
+ $lib = [] unless $lib;
+ my $out = basename($file,'.c').$Config{'exe_ext'};
+ warn "Test Compiling $file\n";
+ my $msgs = `$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib $stderr_too`;
+ my $ok = ($? == 0);
+# warn $msgs if $msgs;
+ unlink($out) if (-f $out);
+ return $ok;
+}
+
+sub try_run
+{
+ my ($file,$inc,$lib) = @_;
+ $inc = [] unless $inc;
+ $lib = [] unless $lib;
+ my $out = basename($file,'.c').$Config{'exe_ext'};
+ warn "Test Compile/Run $file\n";
+ my $msgs = `$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib $stderr_too`;
+ my $ok = ($? == 0);
+# warn "$Config{'cc'} -o $out $Config{'ccflags'} @$inc $file @$lib:\n$msgs" if $msgs;
+ if ($ok)
+ {
+ my $path = File::Spec->rel2abs($out);
+ $msgs = `$path $stderr_too`;
+ $ok = ($? == 0);
+# warn "$path:$msgs" if $msgs;
+ }
+ unlink($out) if (-f $out);
+ return $ok;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/MMutil.pm b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm
new file mode 100644
index 00000000000..84f3aa862f5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/MMutil.pm
@@ -0,0 +1,600 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::MMutil;
+use ExtUtils::MakeMaker;
+use Cwd;
+use Config;
+use Carp;
+use File::Basename;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/;
+
+# warn __FILE__." $VERSION\n";
+
+use Tk::MakeDepend;
+
+use Tk::Config qw(!$VERSION);
+use vars qw($IsWin32);
+
+*IsWin32 = \$main::IsWin32;
+$IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/)
+ unless defined $IsWin32;
+
+@MYEXPORT = qw(pasthru perldepend cflags const_config constants installbin c_o xs_o makefile manifypods);
+
+sub arch_prune
+{
+ my $hash = shift;
+ foreach (keys %$hash)
+ {
+ if ($win_arch eq 'x')
+ {
+ delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/;
+ }
+ elsif ($win_arch eq 'open32')
+ {
+ delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
+ delete $hash->{$_} if /winMain|dllMain/;
+ }
+ elsif ($win_arch eq 'pm')
+ {
+ delete $hash->{$_}
+ if /Unix|Mwm/ and not
+ /tclUnix|Unix(3d|Button|Dialog|Color|Embed|Focus|Font|Menu|Scrlbr|Send|Int\.|Scale)/;
+ delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^x(colors\.c|gc\.)/;
+ delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/;
+ }
+ elsif ($win_arch eq 'MSWin32')
+ {
+ delete $hash->{$_} if /Mwm/ and not /tclUnix/;
+ delete $hash->{$_} if /winMain|dllMain/;
+ # delete $hash->{$_} if /^Xrm/;
+ }
+ }
+}
+
+sub mTk_postamble
+{
+ my ($self) = @_;
+ my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n";
+ my $mTk = $self->{'MTK'};
+ $dep .= "# Begin Munging dependencies\n";
+ foreach my $file (sort keys %$mTk)
+ {
+ $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n";
+ $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n";
+ }
+ $dep .= "# End Munging dependencies\n\n";
+ return $dep;
+}
+
+sub mTk_CHO
+{
+ my $self = shift;
+ my $mTk = shift;
+ my $exc = shift;
+ my %c;
+ my %h;
+ foreach (@{$self->{H}}) { $h{$_} = 1 }
+ foreach (@{$self->{C}}) { $c{$_} = 1 }
+ foreach (keys %$mTk)
+ {
+ if (/\.c$/)
+ {
+ $c{$_} = 1;
+ }
+ elsif (/\.h$/)
+ {
+ $h{$_} = 1;
+ }
+ }
+ foreach (keys %$exc)
+ {
+ if (/\.c$/)
+ {
+ delete $c{$_};
+ }
+ elsif (/\.h$/)
+ {
+ delete $h{$_};
+ }
+ }
+ while (@_)
+ {
+ my $name = shift;
+ cluck("No $name") unless (exists $c{$name});
+ delete $c{$name}
+ }
+ arch_prune(\%h);
+ arch_prune(\%c);
+ $self->{'H'} = [sort keys %h];
+ $self->{'C'} = [sort keys %c];
+ my(@o_files) = @{$self->{C}};
+ $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
+ $self->{'MTK'} = $mTk;
+ my $tk = installed_tk();
+ my $perl = $self->{'PERL'};
+ if ($IsWin32 && !-f $perl && -f "$perl.exe")
+ {
+ print "perl=$perl X=$^X\n";
+ $perl = "$perl.exe";
+ $self->{'PERL'} = $perl;
+ }
+ foreach my $file (sort keys %$mTk)
+ {
+ unless (-f $file && -M $file < -M $mTk->{$file})
+ {
+ warn "Extracting $file\n";
+ system($perl,"$tk/pTk/Tcl-pTk",$mTk->{$file},$file);
+ }
+ }
+}
+
+my %visited;
+
+sub abspath
+{
+ my $dir = shift;
+ my $here = getcwd() || die "Cannot get current directory:$!";
+ if (chdir($dir))
+ {
+ $dir = getcwd();
+ chdir($here) || die "Cannot cd back to $here:$!";
+ }
+ return $dir;
+}
+
+sub relpath
+{
+ my ($path,$dir) = @_;
+ unless (defined $dir)
+ {
+ $dir = (-d $path) ? $path : dirname($path);
+ }
+ if (defined $dir and -d $dir)
+ {
+ if ($path =~ m#^\Q$dir\E([/\\]?.*)$#)
+ {
+ my $base = $1;
+ my $here = getcwd;
+ if ($here =~ m#^\Q$dir\E([/\\]?.*)#)
+ {
+ my $depth = reverse($1);
+ if ($depth)
+ {
+ $depth =~ s,[^/\\]+,..,g;
+ }
+ else
+ {
+ $depth = '.' ;
+ }
+ $depth =~ s,[/\\]+$,,;
+ $base =~ s,^[/\\]+,,;
+ $depth .= "/$base" if ($base);
+ if (-e $depth)
+ {
+ # print "$path is $depth from $here\n";
+ return $depth;
+ }
+ else
+ {
+ warn "Cannot find $depth\n";
+ }
+ }
+ else
+ {
+ unless(exists $visited{$here})
+ {
+ $visited{$here} = 1;
+ warn "$here does not start with $dir\n";
+ warn "i.e. building outside Tk itself\n";
+ }
+ }
+ }
+ else
+ {
+ die "'$path' not under '$dir'\n";
+ }
+ }
+ else
+ {
+ die "Cannot get directory for $path\n";
+ }
+ return $path;
+}
+
+use strict;
+
+sub upgrade_pic
+{
+ my $flags = '';
+ die 'upgrade_pic is obsolete';
+ return $flags;
+}
+
+sub pasthru
+{
+ my $self = shift;
+ my $str = $self->MM::pasthru;
+ if ($str =~ s/^\s+INC=.*\n//m)
+ {
+ $str = "# - Do NOT pasthru INC for Tk - it is computed by subdir\n$str"
+ }
+ if ($str =~ s/\bLIB="\$\(LIB\)"//)
+ {
+ $str = qq[# - Drop LIB="\$(LIB)" - not used\n$str];
+ }
+ $str = "#Tk::MMutil pasthru\n$str";
+ return $str;
+}
+
+sub perldepend
+{
+ my $self = shift;
+ my $str = $self->MM::perldepend;
+ my $name;
+ my %c;
+ foreach my $file (@{$self->{'C'}})
+ {
+ $c{$file} = 1;
+ }
+ foreach my $file (keys %{$self->{'XS'}})
+ {
+ $c{$file} = 1;
+ delete $c{$self->{'XS'}{$file}};
+ }
+ my @files = grep(-f $_,sort(keys %c));
+ if (@files)
+ {
+ my $tk = installed_tk();
+ my @inc = split(/\s+/,$self->{'INC'});
+ my @def = split(/\s+/,$self->{'DEFINE'});
+ push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32);
+ if ($^O eq 'cygwin')
+ {
+ push(@def,qw(-D__CYGWIN__));
+ if ($win_arch eq 'MSWin32')
+ {
+ push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/;
+ push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk';
+ }
+ elsif ($win_arch eq 'x')
+ {
+ push(@def,qw(-U_WIN32));
+ }
+ }
+ foreach (@inc)
+ {
+ s/\$\(TKDIR\)/$tk/g;
+ warn "Odd:$_" if /\$\(/;
+ }
+ $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'});
+ }
+ return $str;
+}
+
+sub const_config
+{
+ my $self = shift;
+ my $name;
+ foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}})
+ {
+ delete $self->{PM}->{$name};
+ }
+ my $flags = $self->{'CCCDLFLAGS'};
+ $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/;
+ $self->{'CCCDLFLAGS'} = $flags;
+ if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/)
+ {
+ $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
+ $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
+ }
+ elsif ($^O eq 'darwin' )
+ {
+ $self->{'LDDLFLAGS'} =~ s/-flat_namespace//;
+ $self->{'LDDLFLAGS'} =~ s/-undefined\s+suppress//;
+ if ( -e "$Config{'archlib'}/CORE/$Config{'libperl'}" ) {
+ $self->{'LDDLFLAGS'} .= " -L\${PERL_ARCHLIB}/CORE -lperl ";
+ }
+ elsif ( -e "/System/Library/Perl/darwin/CORE/libperl.dylib" ) {
+ $self->{'LDDLFLAGS'} .= " -L/System/Library/Perl/darwin/CORE -lperl ";
+ }
+ else {
+ warn "Can't find libperl.dylib";
+ }
+ $self->{'LDFLAGS'} =~ s/-flat_namespace//;
+ $self->{'LDFLAGS'} =~ s/-undefined\s+suppress//;
+ } elsif ($^O =~ /(openbsd)/i)
+ {
+ # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s.
+ $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g;
+ }
+ return $self->MM::const_config;
+}
+
+sub constants
+{
+ my $self = shift;
+ local $_ = $self->MM::constants;
+ s/(\.SUFFIXES)/$1:\n$1/;
+ $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
+ if ($IsWin32)
+ {
+ }
+ $_;
+}
+
+sub cflags
+{
+ my $self = shift;
+ local $_ = $self->MM::cflags;
+ if (0 && $IsWin32)
+ {
+ if ($Config::Config{cc} =~ /^bcc/i) {
+ # s/(CCFLAGS\s*=)/$1/;
+ }
+ else {
+ s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/;
+ s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
+ }
+ }
+ $_;
+}
+
+sub c_o
+{
+ my $self = shift;
+ local $_ = $self->MM::c_o;
+ s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
+ $_;
+}
+
+sub xs_o
+{
+ my $self = shift;
+ local $_ = $self->MM::xs_o;
+ s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
+ $_;
+}
+
+sub manifypods
+{
+ my $self = shift;
+ # Maybe always call UNIX version - we HTMLize them later
+ local $_ = $self->MM::manifypods;
+ if ($] >= 5.00565)
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/;
+ }
+ elsif ($] >= 5.003)
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
+ }
+ else
+ {
+ s/(POD2MAN_EXE.*pod2man.*)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
+ }
+ s/\bpod::/Tk::/mg;
+ s/\bpTk:://mg;
+ $_;
+}
+
+sub findINC
+{
+ my $file = shift;
+ my $dir;
+ foreach $dir (@INC)
+ {
+ my $try = "$dir/$file";
+ return $try if (-f $try);
+ }
+ die "Cannot find $file in \@INC\n";
+}
+
+
+sub makefile
+{
+ my $self = shift;
+ my $str = $self->MM::makefile;
+ my $mm = findINC('Tk/MMutil.pm');
+ my $cf = findINC('Tk/Config.pm');
+ $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
+ $str =~ s/\$\(OBJECT\)\s*:.*\n//;
+ return $str;
+}
+
+sub installed_tk
+{
+ my $tk;
+ my $dir;
+ foreach $dir (@INC)
+ {
+ if (-f "$dir/tkGlue.h")
+ {
+ $tk = relpath($dir);
+ last;
+ }
+ my $try = "$dir/Tk";
+ if (-f "$try/tkGlue.h")
+ {
+ $tk = relpath($try,$dir);
+ last;
+ }
+ }
+ die "Cannot find perl/Tk include files\n" unless (defined $tk);
+ $tk =~ s,^(\./)+,,;
+ return $tk;
+}
+
+sub installbin
+{
+ my ($self) = @_;
+ my $str = $self->MM::installbin;
+ my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
+ my $inc = findINC('Tk/MMutil.pm');
+ $inc =~ s,/Tk/MMutil.pm$,,;
+ $inc = relpath($inc);
+ $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
+ return $str;
+}
+
+sub findpTk
+{
+ my $ptk;
+ my $dir;
+ foreach $dir (map(abspath($_),@_),@INC)
+ {
+ my $try = "$dir/pTk";
+ if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
+ {
+ $ptk = relpath($try,$dir);
+ last;
+ }
+ }
+ confess "Cannot locate pTk\n" unless (defined $ptk);
+ return $ptk;
+}
+
+sub find_subdir
+{
+ my %dir;
+ opendir(DIR,'.') || die "Cannot opendir:$!";
+ foreach my $dir (readdir(DIR))
+ {
+ next if $dir =~ /^\.\.?$/;
+ next if -l $dir;
+ next unless -d $dir;
+ if (-f "$dir/Makefile.PL")
+ {
+ my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win';
+ if (-f "$dir/Not${exc}.exc")
+ {
+ warn "Skip $dir on $win_arch\n"
+ }
+ else
+ {
+ $dir{$dir} = 1
+ }
+ }
+ }
+ closedir(DIR);
+ return \%dir;
+}
+
+sub TkExtMakefile
+{
+ my (%att) = @_;
+ if ($Config{'ccflags'} =~ /-DPERL_OBJECT/)
+ {
+ $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'};
+ }
+ unless (exists $att{'DIR'})
+ {
+ my $dir = find_subdir();
+ $att{'DIR'} = [sort(keys %$dir)];
+ }
+ unless (exists $att{'NAME'})
+ {
+ my $dir = getcwd;
+ my ($pack) = $dir =~ m#/([^/]+)$#;
+ if (defined $pack)
+ {
+ $att{NAME} = 'Tk::'.$pack;
+ }
+ else
+ {
+ warn "No Name and cannot deduce from '$dir'";
+ }
+ }
+ my $tk = installed_tk();
+ $att{'macro'} = {} unless (exists $att{'macro'});
+ $att{'macro'}{'TKDIR'} = $tk;
+ my @opt = ('VERSION' => $Tk::Config::VERSION,
+ 'XS_VERSION' => $Tk::Config::VERSION);
+ push(@opt,'clean' => {} ) unless (exists $att{'clean'});
+ $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
+ $att{'clean'}->{FILES} .= ' *.bak';
+ unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
+ {
+ my $ptk = findpTk($tk);
+ my @tm = (findINC('Tk/typemap'));
+ unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
+ $att{'TYPEMAPS'} = \@tm;
+ my $i = delete ($att{'INC'});
+ $i = (defined $i) ? "$i $inc" : $inc;
+ if (delete $att{'dynamic_ptk'})
+ {
+ push(@opt,
+ 'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
+# 'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" }
+ );
+ }
+ # Several loadable widgets use things from -lm
+ # if platform does not have a shared -lm need to link against it
+ if ($Config{libs} =~/-lm\b/)
+ {
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/;
+ }
+ if ($IsWin32 && $Config{'cc'} =~ /^bcc/)
+ {
+ # Borland compiler is very dumb at finding files
+ $i = "-I$tk $i";
+ $i = "-I$ptk $i";
+ }
+ if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
+ {
+ my $base = $Config{'libpth'};
+ $base =~ s#lib$#i386-mingw32/lib#;
+ my $extra = "-L$base -lcomdlg32 -lgdi32";
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$extra $libs";
+ }
+ if ($^O eq 'cygwin')
+ {
+ # NOTE: use gcc -shared instead of dllwrap (ld2),
+ # dllwrap tries to resolve all symbols, even those
+ # that are brought in from libraries like libpTk.a
+ push(@opt,'LD' => 'gcc -shared');
+ if ($win_arch eq 'MSWin32')
+ {
+ my $extra = "-L/lib/w32api -lcomdlg32 -lgdi32";
+ my $libs = $att{'LIBS'}->[0];
+ $att{'LIBS'}->[0] = "$extra $libs";
+ $att{'DEFINE'} .= ' -D__WIN32__ -D_WIN32';
+ $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk');
+ }
+ elsif ($win_arch eq 'x')
+ {
+ $att{'DEFINE'} .= ' -U_WIN32';
+ }
+ }
+ if (delete $att{'ptk_include'})
+ {
+ $i = "-I$ptk $i" unless ($ptk eq '.');
+ }
+ else
+ {
+ $i = "-I$tk $i" unless ($tk eq '.');
+ }
+ push(@opt,'DEFINE' => $define, 'INC' => $i);
+ }
+ WriteMakefile(@opt, %att);
+}
+
+sub import
+{
+ no strict 'refs';
+ my $class = shift;
+ my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
+ my $name;
+ foreach $name (@list)
+ {
+ *{"MY::$name"} = \&{"$name"};
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm b/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm
new file mode 100644
index 00000000000..5384ccb560b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/MainWindow.pm
@@ -0,0 +1,213 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::MainWindow;
+use base qw(Tk::Toplevel);
+BEGIN { @MainWindow::ISA = 'Tk::MainWindow' }
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::CmdLine;
+use Tk qw(catch);
+require Tk::Toplevel;
+
+use Carp;
+
+$| = 1;
+
+my $pid = $$;
+
+my %Windows = ();
+
+sub CreateArgs
+{
+ my ($class,$args) = @_;
+ my $cmd = Tk::CmdLine->CreateArgs();
+ my $key;
+ foreach $key (keys %$cmd)
+ {
+ $args->{$key} = $cmd->{$key} unless exists $args->{$key};
+ }
+ my %result = $class->SUPER::CreateArgs(undef,$args);
+ my $name = delete($args->{'-name'});
+ unless (Tk::tainting)
+ {
+ $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
+ $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
+ }
+ return (-name => "\l$name",%result);
+}
+
+sub new
+{
+ my $package = shift;
+ if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
+ {
+ carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
+ unshift(@_,'-screen');
+ }
+ croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
+ my %args = @_;
+
+ my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
+ croak($@ . "$package->new(" . join(',',@_) .')') if ($@);
+ $top->apply_command_line;
+ $top->InitBindings;
+ $top->SetBindtags;
+ $top->InitObject(\%args);
+ eval { $top->configure(%args) };
+ croak "$@" if ($@);
+ if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
+ my $geometry = $top->optionGet(qw(geometry Geometry));
+ if ($geometry) {
+ $top->geometry($geometry);
+ }
+ }
+ $Windows{$top} = $top;
+ return $top;
+}
+
+sub _Destroyed
+{
+ my $top = shift;
+ $top->SUPER::_Destroyed;
+ delete $Windows{$top};
+}
+
+sub InitBindings
+{
+ my $mw = shift;
+ $mw->bind('all','<Tab>','focusNext');
+ # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk
+ $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
+ # This is needed for XFree86 systems
+ catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
+ # This seems to be correct on *some* HP systems.
+ catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) };
+ $mw->bind('all','<<LeftTab>>','focusPrev');
+ if ($mw->windowingsystem eq 'x11')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14>
+ <Control-Key-underscore>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
+ }
+ elsif ($mw->windowingsystem eq 'win32')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'aqua')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'classic')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]);
+ }
+
+ # FIXME - Should these move to Menubutton ?
+ my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton';
+ $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]);
+ $mw->bind($c,'<F10>','FirstMenu');
+}
+
+sub Existing
+{
+ my @Windows;
+ foreach my $name (keys %Windows)
+ {
+ my $obj = $Windows{$name};
+ if (Tk::Exists($obj))
+ {
+ push(@Windows,$obj);
+ }
+ else
+ {
+ delete $Windows{$name};
+ }
+ }
+ return @Windows;
+}
+
+END
+{
+ if (Tk::IsParentProcess())
+ {
+ foreach my $top (values %Windows)
+ {
+ if ($top->IsWidget)
+ {
+ # Tk data structuctures are still in place
+ # this can occur if non-callback perl code did a 'die'.
+ # It will also handle some cases of non-Tk 'exit' being called
+ # Destroy this mainwindow and hence is descendants ...
+ $top->destroy;
+ }
+ }
+ }
+}
+
+sub CmdLine { return shift->command }
+
+sub WMSaveYourself
+{
+ my $mw = shift;
+ my @args = @{$mw->command};
+# warn 'preWMSaveYourself:'.join(' ',@args)."\n";
+ @args = ($0) unless (@args);
+ my $i = 1;
+ while ($i < @args)
+ {
+ if ($args[$i] eq '-iconic')
+ {
+ splice(@args,$i,1);
+ }
+ elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
+ {
+ splice(@args,$i,2);
+ }
+ }
+
+ my @ip = $mw->wm('iconposition');
+# print 'ip ',join(',',@ip),"\n";
+ my $icon = $mw->iconwindow;
+ if (defined($icon))
+ {
+ @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
+ }
+ splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
+
+ splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
+
+ splice(@args,1,0,'-geometry' => $mw->geometry);
+# warn 'postWMSaveYourself:'.join(' ',@args)."\n";
+ $mw->command([@args]);
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm
new file mode 100644
index 00000000000..bfb7b43ccbc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/MakeDepend.pm
@@ -0,0 +1,292 @@
+package Tk::MakeDepend;
+use strict;
+use vars qw(%define);
+use Config;
+
+my @include;
+
+use Carp;
+
+$SIG{__DIE__} = \&Carp::confess;
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+sub scan_file;
+
+sub do_include
+{
+ my ($inc,$dep,@include) = @_;
+ foreach my $dir (@include)
+ {
+ my $path = "$dir/$inc";
+ if (-f $path)
+ {
+ scan_file($path,$dep) unless exists $dep->{$path};
+ return;
+ }
+ }
+ warn "Cannot find '$inc' assume made\n";
+ $dep->{$inc} = 1;
+}
+
+sub remove_comment
+{
+ s#^\s*/\*.*?\*/\s*##g;
+}
+
+
+sub term
+{
+ remove_comment();
+ return !term() if s/^\s*!//;
+ return exists($define{$1}) if s/^\s*defined\s*\(([_A-Za-z][_\w]*)\s*\)//;
+ return exists($define{$1}) if s/^\s*defined\s*([_A-Za-z][_\w]*)//;
+ return eval "$1" if s/^\s*(0x[0-9a-f]+)//i;
+ return $1 if s/^\s*(\d+)//;
+ return $define{$1} || 0 if s/^\s*([_A-Za-z][_\w]*)//;
+ if (s/^\s*\(//)
+ {
+ my $val = expression(0);
+ warn "Missing ')'\n" unless s/^\s*\)//;
+ return $val;
+ }
+ warn "Invalid term:$_";
+ return undef;
+}
+
+my %pri = ( '&&' => 4,
+ '||' => 3,
+ '>=' => 2, '<=' => 2, '<' => 2, '>' => 2,
+ '==' => 1, '!=' => 1 );
+
+sub expression
+{
+ my $pri = shift;
+ # printf STDERR "%d# expr . $_\n";
+ my $invert = 0;
+ my $lhs = term() || 0;
+ remove_comment();
+ while (/^\s*(&&|\|\||>=?|<=?|==|!=)/)
+ {
+ my $op = $1;
+ last unless ($pri{$op} >= $pri);
+ s/^\s*\Q$op\E//;
+ # printf STDERR "%d# $lhs $op . $_\n";
+ my $rhs = expression($pri{$op}) || 0;
+ my $e = "$lhs $op $rhs";
+ $lhs = eval "$e" || 0;
+ die "'$e' $@" if $@;
+ remove_comment();
+ }
+ return $lhs;
+}
+
+sub do_if
+{
+ my ($key,$expr) = @_;
+ chomp($expr);
+ if ($key eq 'ifdef' || $key eq 'ifndef')
+ {
+ if ($expr =~ /^\s*(\w+)/)
+ {
+ my $val = exists $define{$1};
+ $val = !$val if ($key eq 'ifndef');
+# printf STDERR "%d from $key $expr\n",$val;
+ return $val;
+ }
+ }
+ else
+ {
+ local $_ = $expr;
+ my $val = expression(0) != 0;
+ warn "trailing: $_" if /\S/;
+ #printf STDERR "%d from $key $expr\n",$val;
+ return $val;
+ }
+}
+
+sub scan_file
+{
+ no strict 'refs';
+ my ($file,$dep) = @_;
+ open($file,"<$file") || die "Cannot open $file:$!";
+ local $_;
+ my ($srcdir) = $file =~ m#^(.*)[\\/][^\\/]*$#;
+ $srcdir = '.' unless defined $srcdir;
+ my $live = 1;
+ $dep->{$file} = 1;
+ my @stack;
+ while (<$file>)
+ {
+ $_ .= <$file> while (s/\\\n/ /);
+ if (/^\s*#\s*(\w+)\s*(.*?)\s*$/)
+ {
+ my $ol = $live;
+ my $key = $1;
+ my $rest = $2;
+ if ($key =~ /^if(.*)$/)
+ {
+ push(@stack,$live);
+ $live &&= do_if($key,$rest);
+ }
+ elsif ($key eq 'elif')
+ {
+ $live = ($live) ? 0 : $stack[-1];
+ $live &&= do_if('if',$rest);
+ }
+ elsif ($key eq 'else')
+ {
+ $live = ($live) ? 0 : $stack[-1];
+ }
+ elsif ($key eq 'endif')
+ {
+ if (@stack)
+ {
+ $live = pop(@stack);
+ }
+ else
+ {
+ die "$file:$.: Mismatched #endif\n";
+ }
+ }
+ elsif ($live)
+ {
+ if ($key eq 'include')
+ {
+ do_include($1,$dep,$srcdir,@include) if $rest =~ /^"(.*)"/;
+ }
+ elsif ($key eq 'define')
+ {
+ if ($rest =~ /^\s*([_A-Za-z][\w_]*)\s*(.*)$/)
+ {
+ my $sym = $1;
+ my $val = $2 || 1;
+ $val =~ s#\s*/\*.*?\*/\s*# #g;
+ $define{$sym} = $val;
+ }
+ else
+ {
+ warn "ignore '$key $rest'\n";
+ }
+ }
+ elsif ($key eq 'undef')
+ {
+ if ($rest =~ /^\s*([_A-Za-z][\w_]*)/)
+ {
+ delete $define{$1};
+ }
+ }
+ elsif ($key =~ /^(line|pragma)$/)
+ {
+
+ }
+ else
+ {
+ warn "ignore '$key $rest'\n";
+ }
+ }
+ # printf STDERR "$file:$.: %d $key $rest\n",$live if ($ol != $live);
+ }
+ else
+ {
+ # print if $live;
+ }
+ }
+ close($file);
+ if (@stack)
+ {
+ warn "$file:$.: unclosed #if\n";
+ }
+}
+
+sub command_line
+{
+ @include = ();
+ local %define = ('__STDC__' => 1 );
+ my $data = '';
+ my @files;
+ while (@_ && $_[-1] !~ /^-/)
+ {
+ unshift(@files,pop(@_));
+ }
+ my $flags = $Config{ccflags};
+ $flags =~ s/^\s+|\s+$//g;
+ my @opt = (@_, split(/\s+/,$flags));
+ while (@opt)
+ {
+ local $_ = shift(@opt);
+ if (/^-I(.*)$/)
+ {
+ push @include,$1;
+ }
+ elsif (/^-D([^=]+)(?:=(.*))?$/)
+ {
+ $define{$1} = $2 || 1;
+ }
+ elsif (/^-U(.*)$/)
+ {
+ delete $define{$1};
+ }
+ elsif (/^(-.*)$/)
+ {
+ # Some option
+ if ($opt[0] !~ /^-/)
+ {
+ # next arg does not start with '-' assume it
+ # belongs to this option and discard it silently
+ shift(@opt);
+ }
+ }
+ else
+ {
+ # We got confused
+ warn "Ignoring $1\n";
+ }
+ }
+ # force /usr/include to be last element of @include
+ push @include, $Config{'usrinc'}
+ if (defined $Config{'usrinc'} and $Config{'usrinc'} ne '');
+ # warn "Include:@include\n";
+ while (@files)
+ {
+ local $_ = shift(@files);
+ unless (/^(.*)\.[^\.]+$/)
+ {
+ warn "Skip $_";
+ next;
+ }
+ local %define = %define;
+ my $base = $1;
+ my $file = $_;
+ my %dep;
+ warn "Finding dependencies for $file\n";
+ scan_file($_,\%dep);
+ my $str = "\n$base\$(OBJ_EXT) : $base.c";
+ delete $dep{$file};
+ my @dep = (sort(keys %dep));
+ while (@dep)
+ {
+ my $dep = shift(@dep);
+ $dep =~ s#^\./##;
+ if (length($str)+length($dep) > 70)
+ {
+ $data .= "$str \\\n";
+ $str = ' ';
+ }
+ else
+ {
+ $str .= ' ';
+ }
+ $str .= $dep;
+ }
+ $data .= "$str\n";
+ }
+ return $data;
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu.pm b/Master/tlpkg/tlperl/lib/Tk/Menu.pm
new file mode 100644
index 00000000000..91e9aceed61
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Menu.pm
@@ -0,0 +1,1145 @@
+# Converted from menu.tcl --
+#
+# This file defines the default bindings for Tk menus and menubuttons.
+# It also implements keyboard traversal of menus and implements a few
+# other utility procedures related to menus.
+#
+# @(#) menu.tcl 1.34 94/12/19 17:09:09
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package Tk::Menu;
+require Tk;
+require Tk::Widget;
+require Tk::Wm;
+require Tk::Derived;
+require Tk::Menu::Item;
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/;
+
+use strict;
+
+use base qw(Tk::Wm Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Menu';
+
+sub Tk_cmd { \&Tk::_menu }
+
+Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure',
+ 'index','insert','invoke','post','postcascade','type',
+ 'unpost','yposition');
+
+import Tk qw(Ev);
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -class for Frame)
+ # return these as a list of -key => value pairs
+ my @result = ();
+ my $opt;
+ foreach $opt (qw(-type -screen -visual -colormap))
+ {
+ my $val = delete $args->{$opt};
+ push(@result, $opt => $val) if (defined $val);
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($menu,$args) = @_;
+ my $menuitems = delete $args->{-menuitems};
+ $menu->SUPER::InitObject($args);
+ $menu->ConfigSpecs(-foreground => ['SELF']);
+ if (defined $menuitems)
+ {
+ # If any other args do configure now
+ if (%$args)
+ {
+ $menu->configure(%$args);
+ %$args = ();
+ }
+ $menu->AddItems(@$menuitems)
+ }
+}
+
+sub AddItems
+{
+ my $menu = shift;
+ ITEM:
+ while (@_)
+ {
+ my $item = shift;
+ if (!ref($item))
+ {
+ $menu->separator; # A separator
+ }
+ else
+ {
+ my ($kind,$name,%minfo) = ( @$item );
+ my $invoke = delete $minfo{'-invoke'};
+ if (defined $name)
+ {
+ $minfo{-label} = $name unless defined($minfo{-label});
+ $menu->$kind(%minfo);
+ }
+ else
+ {
+ $menu->BackTrace("Don't recognize " . join(' ',@$item));
+ }
+ } # A non-separator
+ }
+}
+
+#
+#-------------------------------------------------------------------------
+# Elements of tkPriv that are used in this file:
+#
+# cursor - Saves the -cursor option for the posted menubutton.
+# focus - Saves the focus during a menu selection operation.
+# Focus gets restored here when the menu is unposted.
+# inMenubutton - The name of the menubutton widget containing
+# the mouse, or an empty string if the mouse is
+# not over any menubutton.
+# popup - If a menu has been popped up via tk_popup, this
+# gives the name of the menu. Otherwise this
+# value is empty.
+# postedMb - Name of the menubutton whose menu is currently
+# posted, or an empty string if nothing is posted
+# A grab is set on this widget.
+# relief - Used to save the original relief of the current
+# menubutton.
+# window - When the mouse is over a menu, this holds the
+# name of the menu; it's cleared when the mouse
+# leaves the menu.
+#-------------------------------------------------------------------------
+#-------------------------------------------------------------------------
+# Overall note:
+# This file is tricky because there are four different ways that menus
+# can be used:
+#
+# 1. As a pulldown from a menubutton. This is the most common usage.
+# In this style, the variable tkPriv(postedMb) identifies the posted
+# menubutton.
+# 2. As a torn-off menu copied from some other menu. In this style
+# tkPriv(postedMb) is empty, and the top-level menu is no
+# override-redirect.
+# 3. As an option menu, triggered from an option menubutton. In thi
+# style tkPriv(postedMb) identifies the posted menubutton.
+# 4. As a popup menu. In this style tkPriv(postedMb) is empty and
+# the top-level menu is override-redirect.
+#
+# The various binding procedures use the state described above to
+# distinguish the various cases and take different actions in each
+# case.
+#-------------------------------------------------------------------------
+# Bind --
+# This procedure is invoked the first time the mouse enters a menubutton
+# widget or a menubutton widget receives the input focus. It creates
+# all of the class bindings for both menubuttons and menus.
+#
+# Arguments:
+# w - The widget that was just entered or just received
+# the input focus.
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ # Must set focus when mouse enters a menu, in order to allow
+ # mixed-mode processing using both the mouse and the keyboard.
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]);
+ $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]);
+ $mw->bind($class,'<ButtonPress>','ButtonDown');
+ $mw->bind($class,'<ButtonRelease>',['Invoke',1]);
+ $mw->bind($class,'<space>',['Invoke',0]);
+ $mw->bind($class,'<Return>',['Invoke',0]);
+ $mw->bind($class,'<Escape>','Escape');
+ $mw->bind($class,'<Left>','LeftArrow');
+ $mw->bind($class,'<Right>','RightArrow');
+ $mw->bind($class,'<Up>','UpArrow');
+ $mw->bind($class,'<Down>','DownArrow');
+ $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]);
+ $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]);
+ return $class;
+}
+
+sub UpArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextMenu('left');
+ }
+ else
+ {
+ $menu->NextEntry(-1);
+ }
+}
+
+sub DownArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextMenu('right');
+ }
+ else
+ {
+ $menu->NextEntry(1);
+ }
+}
+
+sub LeftArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextEntry(-1);
+ }
+ else
+ {
+ $menu->NextMenu('left');
+ }
+}
+
+sub RightArrow
+{
+ my $menu = shift;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ $menu->NextEntry(1);
+ }
+ else
+ {
+ $menu->NextMenu('right');
+ }
+}
+
+
+
+# Unpost --
+# This procedure unposts a given menu, plus all of its ancestors up
+# to (and including) a menubutton, if any. It also restores various
+# values to what they were before the menu was posted, and releases
+# a grab if there's a menubutton involved. Special notes:
+# 1. It's important to unpost all menus before releasing the grab, so
+# that any Enter-Leave events (e.g. from menu back to main
+# application) have mode NotifyGrab.
+# 2. Be sure to enclose various groups of commands in "catch" so that
+# the procedure will complete even if the menubutton or the menu
+# or the grab window has been deleted.
+#
+# Arguments:
+# menu - Name of a menu to unpost. Ignored if there
+# is a posted menubutton.
+sub Unpost
+{
+ my $menu = shift;
+ my $mb = $Tk::postedMb;
+
+ # Restore focus right away (otherwise X will take focus away when
+ # the menu is unmapped and under some window managers (e.g. olvwm)
+ # we'll lose the focus completely).
+
+ eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus);
+ undef $Tk::focus;
+
+ # Unpost menu(s) and restore some stuff that's dependent on
+ # what was posted.
+ eval {local $SIG{__DIE__};
+ if (defined $mb)
+ {
+ $menu = $mb->cget('-menu');
+ $menu->unpost();
+ $Tk::postedMb = undef;
+ $mb->configure('-cursor',$Tk::cursor);
+ $mb->configure('-relief',$Tk::relief)
+ }
+ elsif (defined $Tk::popup)
+ {
+ $Tk::popup->unpost();
+ my $grab = $Tk::popup->grabCurrent;
+ $grab->grabRelease if (defined $grab);
+
+ undef $Tk::popup;
+ }
+ elsif (defined $menu && ref $menu &&
+ $menu->cget('-type') ne 'menubar' &&
+ $menu->cget('-type') ne 'tearoff'
+ )
+ {
+ # We're in a cascaded sub-menu from a torn-off menu or popup.
+ # Unpost all the menus up to the toplevel one (but not
+ # including the top-level torn-off one) and deactivate the
+ # top-level torn off menu if there is one.
+ while (1)
+ {
+ my $parent = $menu->parent;
+ last if (!$parent->IsMenu || !$parent->ismapped);
+ $parent->postcascade('none');
+ $parent->GenerateMenuSelect;
+ $parent->activate('none');
+ my $type = $parent->cget('-type');
+ last if ($type eq 'menubar' || $type eq 'tearoff');
+ $menu = $parent
+ }
+ $menu->unpost() if ($menu->cget('-type') ne 'menubar');
+ }
+ };
+ warn "$@" if ($@);
+ if ($Tk::tearoff || $Tk::menubar)
+ {
+ # Release grab, if any.
+ if (defined $menu && ref $menu)
+ {
+ my $grab = $menu->grabCurrent;
+ $grab->grabRelease if (defined $grab);
+ }
+ RestoreOldGrab();
+ if ($Tk::menubar)
+ {
+ $Tk::menubar->configure(-cursor => $Tk::cursor);
+ undef $Tk::menubar;
+ }
+ if ($Tk::platform ne 'unix')
+ {
+ undef $Tk::tearoff;
+ }
+ }
+}
+
+sub RestoreOldGrab
+{
+ if (defined $Tk::oldGrab)
+ {
+ eval
+ {
+ local $SIG{__DIE__};
+ if ($Tk::grabStatus eq 'global')
+ {
+ $Tk::oldGrab->grabGlobal;
+ }
+ else
+ {
+ $Tk::oldGrab->grab;
+ }
+ };
+ undef $Tk::oldGrab;
+ }
+}
+
+sub typeIS
+{my $w = shift;
+ my $type = $w->type(shift);
+ return defined $type && $type eq shift;
+}
+
+# Motion --
+# This procedure is called to handle mouse motion events for menus.
+# It does two things. First, it resets the active element in the
+# menu, if the mouse is over the menu. Second, if a mouse button
+# is down, it posts and unposts cascade entries to match the mouse
+# position.
+#
+# Arguments:
+# menu - The menu window.
+# y - The y position of the mouse.
+# state - Modifier state (tells whether buttons are down).
+sub Motion
+{
+ my $menu = shift;
+ my $x = shift;
+ my $y = shift;
+ my $state = shift;
+ my $t = $menu->cget('-type');
+
+ if ($menu->IS($Tk::window))
+ {
+ if ($menu->cget('-type') eq 'menubar')
+ {
+# if (defined($Tk::focus) && $Tk::focus != $menu)
+ {
+ $menu->activate("\@$x,$y");
+ $menu->GenerateMenuSelect;
+ }
+ }
+ else
+ {
+ $menu->activate("\@$x,$y");
+ $menu->GenerateMenuSelect;
+ }
+ }
+ if (($state & 0x1f00) != 0)
+ {
+ $menu->postcascade('active')
+ }
+}
+# ButtonDown --
+# Handles button presses in menus. There are a couple of tricky things
+# here:
+# 1. Change the posted cascade entry (if any) to match the mouse position.
+# 2. If there is a posted menubutton, must grab to the menubutton so
+# that it can track mouse motions over other menubuttons and change
+# the posted menu.
+# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
+# or one of its descendants) must grab to the top-level menu so that
+# we can track mouse motions across the entire menu hierarchy.
+
+#
+# Arguments:
+# menu - The menu window.
+sub ButtonDown
+{
+ my $menu = shift;
+ $menu->postcascade('active');
+ if (defined $Tk::postedMb)
+ {
+ $Tk::postedMb->grabGlobal
+ }
+ else
+ {
+ while ($menu->cget('-type') eq 'normal'
+ && $menu->parent->IsMenu
+ && $menu->parent->ismapped
+ )
+ {
+ $menu = $menu->parent;
+ }
+
+ if (!defined $Tk::menuBar)
+ {
+ $Tk::menuBar = $menu;
+ $Tk::cursor = $menu->cget('-cursor');
+ $menu->configure(-cursor => 'arrow');
+ }
+
+ # Don't update grab information if the grab window isn't changing.
+ # Otherwise, we'll get an error when we unpost the menus and
+ # restore the grab, since the old grab window will not be viewable
+ # anymore.
+
+ $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent));
+
+ # Must re-grab even if the grab window hasn't changed, in order
+ # to release the implicit grab from the button press.
+
+ $menu->grabGlobal if ($Tk::platform eq 'unix');
+ }
+}
+
+sub Enter
+{
+ my $w = shift;
+ my $ev = $w->XEvent;
+ $Tk::window = $w;
+ if ($w->cget('-type') eq 'tearoff')
+ {
+ if ($ev->m ne 'NotifyUngrab')
+ {
+ $w->SetFocus if ($Tk::platform eq 'unix');
+ }
+ }
+ $w->Motion($ev->x, $ev->y, $ev->s);
+}
+
+# Leave --
+# This procedure is invoked to handle Leave events for a menu. It
+# deactivates everything unless the active element is a cascade element
+# and the mouse is now over the submenu.
+#
+# Arguments:
+# menu - The menu window.
+# rootx, rooty - Root coordinates of mouse.
+# state - Modifier state.
+sub Leave
+{
+ my $menu = shift;
+ my $rootx = shift;
+ my $rooty = shift;
+ my $state = shift;
+ undef $Tk::window;
+ return if ($menu->index('active') eq 'none');
+ if ($menu->typeIS('active','cascade'))
+ {
+ my $c = $menu->Containing($rootx,$rooty);
+ return if (defined $c && $menu->entrycget('active','-menu')->IS($c));
+ }
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+}
+
+# Invoke --
+# This procedure is invoked when button 1 is released over a menu.
+# It invokes the appropriate menu action and unposts the menu if
+# it came from a menubutton.
+#
+# Arguments:
+# w - Name of the menu widget.
+sub Invoke
+{
+ my $w = shift;
+ my $release = shift;
+
+ if ($release && !defined($Tk::window))
+ {
+ # Mouse was pressed over a menu without a menu button, then
+ # dragged off the menu (possibly with a cascade posted) and
+ # released. Unpost everything and quit.
+
+ $w->postcascade('none');
+ $w->activate('none');
+ $w->eventGenerate('<<MenuSelect>>');
+ $w->Unpost;
+ return;
+ }
+
+ my $type = $w->type('active');
+ if ($w->typeIS('active','cascade'))
+ {
+ $w->postcascade('active');
+ my $menu = $w->entrycget('active','-menu');
+ $menu->FirstEntry() if (defined $menu);
+ }
+ elsif ($w->typeIS('active','tearoff'))
+ {
+ $w->Unpost();
+ $w->tearOffMenu();
+ }
+ elsif ($w->typeIS('active','menubar'))
+ {
+ $w->postcascade('none');
+ $w->activate('none');
+ $w->eventGenerate('<<MenuSelect>>');
+ $w->Unpost;
+ }
+ else
+ {
+ $w->Unpost();
+ $w->invoke('active')
+ }
+}
+# Escape --
+# This procedure is invoked for the Cancel (or Escape) key. It unposts
+# the given menu and, if it is the top-level menu for a menu button,
+# unposts the menu button as well.
+#
+# Arguments:
+# menu - Name of the menu window.
+sub Escape
+{
+ my $menu = shift;
+ my $parent = $menu->parent;
+ if (!$parent->IsMenu)
+ {
+ $menu->Unpost()
+ }
+ elsif ($parent->cget('-type') eq 'menubar')
+ {
+ $menu->Unpost;
+ RestoreOldGrab();
+ }
+ else
+ {
+ $menu->NextMenu(-1)
+ }
+}
+# LeftRight --
+# This procedure is invoked to handle "left" and "right" traversal
+# motions in menus. It traverses to the next menu in a menu bar,
+# or into or out of a cascaded menu.
+#
+# Arguments:
+# menu - The menu that received the keyboard
+# event.
+# direction - Direction in which to move: "left" or "right"
+sub NextMenu
+{
+ my $menu = shift;
+ my $direction = shift;
+ # First handle traversals into and out of cascaded menus.
+ my $count;
+ if ($direction eq 'right')
+ {
+ $count = 1;
+ if ($menu->typeIS('active','cascade'))
+ {
+ $menu->postcascade('active');
+ my $m2 = $menu->entrycget('active','-menu');
+ $m2->FirstEntry if (defined $m2);
+ return;
+ }
+ else
+ {
+ my $parent = $menu->parent;
+ while ($parent->PathName ne '.')
+ {
+ if ($parent->IsMenu && $parent->cget('-type') eq 'menubar')
+ {
+ $parent->SetFocus;
+ $parent->NextEntry(1);
+ return;
+ }
+ $parent = $parent->parent;
+ }
+ }
+ }
+ else
+ {
+ $count = -1;
+ my $m2 = $menu->parent;
+ if ($m2->IsMenu)
+ {
+ if ($m2->cget('-type') ne 'menubar')
+ {
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+ $m2->SetFocus;
+ # This code unposts any posted submenu in the parent.
+ my $tmp = $m2->index('active');
+ $m2->activate('none');
+ $m2->activate($tmp);
+ return;
+ }
+ }
+ }
+ # Can't traverse into or out of a cascaded menu. Go to the next
+ # or previous menubutton, if that makes sense.
+
+ my $m2 = $menu->parent;
+ if ($m2->IsMenu)
+ {
+ if ($m2->cget('-type') eq 'menubar')
+ {
+ $m2->SetFocus;
+ $m2->NextEntry(-1);
+ return;
+ }
+ }
+
+ my $w = $Tk::postedMb;
+ return unless defined $w;
+ my @buttons = $w->parent->children;
+ my $length = @buttons;
+ my $i = Tk::lsearch(\@buttons,$w)+$count;
+ my $mb;
+ while (1)
+ {
+ while ($i < 0)
+ {
+ $i += $length
+ }
+ while ($i >= $length)
+ {
+ $i += -$length
+ }
+ $mb = $buttons[$i];
+ last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled'
+ && defined($mb->cget('-menu'))
+ && $mb->cget('-menu')->index('last') ne 'none'
+ );
+ return if ($mb == $w);
+ $i += $count
+ }
+ $mb->PostFirst();
+}
+# NextEntry --
+# Activate the next higher or lower entry in the posted menu,
+# wrapping around at the ends. Disabled entries are skipped.
+#
+# Arguments:
+# menu - Menu window that received the keystroke.
+# count - 1 means go to the next lower entry,
+# -1 means go to the next higher entry.
+sub NextEntry
+{
+ my $menu = shift;
+ my $count = shift;
+ if ($menu->index('last') eq 'none')
+ {
+ return;
+ }
+ my $length = $menu->index('last')+1;
+ my $quitAfter = $length;
+ my $active = $menu->index('active');
+ my $i = ($active eq 'none') ? 0 : $active+$count;
+ while (1)
+ {
+ return if ($quitAfter <= 0);
+ while ($i < 0)
+ {
+ $i += $length
+ }
+ while ($i >= $length)
+ {
+ $i += -$length
+ }
+ my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') };
+ last if (defined($state) && $state ne 'disabled');
+ return if ($i == $active);
+ $i += $count;
+ $quitAfter -= 1;
+ }
+ $menu->activate($i);
+ $menu->GenerateMenuSelect;
+ if ($menu->cget('-type') eq 'menubar' && $menu->type($i) eq 'cascade')
+ {
+ my $cascade = $menu->entrycget($i, '-menu');
+ $menu->postcascade($i);
+ $cascade->FirstEntry if (defined $cascade);
+ }
+}
+
+
+# tkTraverseWithinMenu
+# This procedure implements keyboard traversal within a menu. It
+# searches for an entry in the menu that has "char" underlined. If
+# such an entry is found, it is invoked and the menu is unposted.
+#
+# Arguments:
+# w - The name of the menu widget.
+# char - The character to look for; case is
+# ignored. If the string is empty then
+# nothing happens.
+sub TraverseWithinMenu
+{
+ my $w = shift;
+ my $char = shift;
+ return unless (defined $char);
+ $char = "\L$char";
+ my $last = $w->index('last');
+ return if ($last eq 'none');
+ for (my $i = 0;$i <= $last;$i += 1)
+ {
+ my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') };
+ next unless defined($label);
+ my $ul = $w->entrycget($i,'-underline');
+ if (defined $ul && $ul >= 0)
+ {
+ $label = substr("\L$label",$ul,1);
+ if (defined($label) && $label eq $char)
+ {
+ if ($w->type($i) eq 'cascade')
+ {
+ $w->postcascade($i);
+ $w->activate($i);
+ my $m2 = $w->entrycget($i,'-menu');
+ $m2->FirstEntry if (defined $m2);
+ }
+ else
+ {
+ $w->Unpost();
+ $w->invoke($i);
+ }
+ return;
+ }
+ }
+ }
+}
+
+sub FindMenu
+{
+ my ($menu,$char) = @_;
+ if ($menu->cget('-type') eq 'menubar')
+ {
+ if (!defined($char) || $char eq '')
+ {
+ $menu->FirstEntry;
+ }
+ else
+ {
+ $menu->TraverseWithinMenu($char);
+ }
+ return $menu;
+ }
+ return undef;
+}
+
+
+# FirstEntry --
+# Given a menu, this procedure finds the first entry that isn't
+# disabled or a tear-off or separator, and activates that entry.
+# However, if there is already an active entry in the menu (e.g.,
+# because of a previous call to tkPostOverPoint) then the active
+# entry isn't changed. This procedure also sets the input focus
+# to the menu.
+#
+# Arguments:
+# menu - Name of the menu window (possibly empty).
+sub FirstEntry
+{
+ my $menu = shift;
+ return if (!defined($menu) || $menu eq '' || !ref($menu));
+ $menu->SetFocus;
+ return if ($menu->index('active') ne 'none');
+ my $last = $menu->index('last');
+ return if ($last eq 'none');
+ for (my $i = 0;$i <= $last;$i += 1)
+ {
+ my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') };
+ if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff'))
+ {
+ $menu->activate($i);
+ $menu->GenerateMenuSelect;
+ if ($menu->type($i) eq 'cascade')
+ {
+ my $cascade = $menu->entrycget($i,'-menu');
+ if (defined $cascade)
+ {
+ $menu->postcascade($i);
+ $cascade->FirstEntry;
+ }
+ }
+ return;
+ }
+ }
+}
+
+# FindName --
+# Given a menu and a text string, return the index of the menu entry
+# that displays the string as its label. If there is no such entry,
+# return an empty string. This procedure is tricky because some names
+# like "active" have a special meaning in menu commands, so we can't
+# always use the "index" widget command.
+#
+# Arguments:
+# menu - Name of the menu widget.
+# s - String to look for.
+sub FindName
+{
+ my $menu = shift;
+ my $s = shift;
+ my $i = undef;
+ if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/)
+ {
+ $i = eval {local $SIG{__DIE__}; $menu->index($s) };
+ return $i;
+ }
+ my $last = $menu->index('last');
+ return if ($last eq 'none');
+ for ($i = 0;$i <= $last;$i += 1)
+ {
+ my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') };
+ return $i if (defined $label && $label eq $s);
+ }
+ return undef;
+}
+# PostOverPoint --
+# This procedure posts a given menu such that a given entry in the
+# menu is centered over a given point in the root window. It also
+# activates the given entry.
+#
+# Arguments:
+# menu - Menu to post.
+# x, y - Root coordinates of point.
+# entry - Index of entry within menu to center over (x,y).
+# If omitted or specified as {}, then the menu's
+# upper-left corner goes at (x,y).
+sub PostOverPoint
+{
+ my $menu = shift;
+ my $x = shift;
+ my $y = shift;
+ my $entry = shift;
+ if (defined $entry)
+ {
+ if ($entry == $menu->index('last'))
+ {
+ $y -= ($menu->yposition($entry)+$menu->height)/2;
+ }
+ else
+ {
+ $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2;
+ }
+ $x -= $menu->reqwidth/2;
+ }
+ $menu->post($x,$y);
+ if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled')
+ {
+ $menu->activate($entry);
+ $menu->GenerateMenuSelect;
+ }
+}
+# tk_popup --
+# This procedure pops up a menu and sets things up for traversing
+# the menu and its submenus.
+#
+# Arguments:
+# menu - Name of the menu to be popped up.
+# x, y - Root coordinates at which to pop up the
+# menu.
+# entry - Index of a menu entry to center over (x,y).
+# If omitted or specified as {}, then menu's
+# upper-left corner goes at (x,y).
+sub Post
+{
+ my $menu = shift;
+ return unless (defined $menu);
+ my $x = shift;
+ my $y = shift;
+ my $entry = shift;
+ Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb));
+ $menu->PostOverPoint($x,$y,$entry);
+ $menu->grabGlobal;
+ $Tk::popup = $menu;
+ $Tk::focus = $menu->focusCurrent;
+ $menu->focus();
+}
+
+sub SetFocus
+{
+ my $menu = shift;
+ $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus));
+ $menu->focus;
+}
+
+sub GenerateMenuSelect
+{
+ my $menu = shift;
+ $Tk::activeMenu = $menu;
+ $Tk::activeItem = $menu->index('active');
+ $menu->eventGenerate('<<MenuSelect>>'); # FIXME
+}
+
+# Converted from tearoff.tcl --
+#
+# This file contains procedures that implement tear-off menus.
+#
+# @(#) tearoff.tcl 1.3 94/12/17 16:05:25
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# tkTearoffMenu --
+# Given the name of a menu, this procedure creates a torn-off menu
+# that is identical to the given menu (including nested submenus).
+# The new torn-off menu exists as a toplevel window managed by the
+# window manager. The return value is the name of the new menu.
+#
+# Arguments:
+# w - The menu to be torn-off (duplicated).
+sub tearOffMenu
+{
+ my $w = shift;
+ my $x = (@_) ? shift : 0;
+ my $y = (@_) ? shift : 0;
+
+ $x = $w->rootx if $x == 0;
+ $y = $w->rooty if $y == 0;
+
+ # Find a unique name to use for the torn-off menu. Find the first
+ # ancestor of w that is a toplevel but not a menu, and use this as
+ # the parent of the new menu. This guarantees that the torn off
+ # menu will be on the same screen as the original menu. By making
+ # it a child of the ancestor, rather than a child of the menu, it
+ # can continue to live even if the menu is deleted; it will go
+ # away when the toplevel goes away.
+
+ my $parent = $w->parent;
+ while ($parent->toplevel != $parent || $parent->IsMenu)
+ {
+ $parent = $parent->parent;
+ }
+ my $menu = $w->clone($parent->PathName,'tearoff');
+
+ # Pick a title for the new menu by looking at the parent of the
+ # original: if the parent is a menu, then use the text of the active
+ # entry. If it's a menubutton then use its text.
+ my $title = $w->cget('-title');
+ # print ref($w),' ',$w->PathName," $w\n";
+ unless (defined $title && length($title))
+ {
+ $parent = $w->parent;
+ if ($parent)
+ {
+ if ($parent->IsMenubutton)
+ {
+ $title = $parent->cget('-text');
+ }
+ elsif ($parent->IsMenu)
+ {
+ $title = $parent->entrycget('active','-label');
+ }
+ }
+ }
+ $menu->title($title) if (defined $title && length($title));
+ $menu->post($x,$y);
+ # Set tkPriv(focus) on entry: otherwise the focus will get lost
+ # after keyboard invocation of a sub-menu (it will stay on the
+ # submenu).
+
+
+ # This seems to conflict with <Enter> class binding above
+ # if this fires before the class binding the wrong thing
+ # will get saved in $Tk::focus
+ # $menu->bind('<Enter>','EnterFocus');
+ $menu->Callback('-tearoffcommand');
+ return $menu;
+}
+
+# tkMenuDup --
+# Given a menu (hierarchy), create a duplicate menu (hierarchy)
+# in a given window.
+#
+# Arguments:
+# src - Source window. Must be a menu. It and its
+# menu descendants will be duplicated at path.
+# path - Name to use for topmost menu in duplicate
+# hierarchy.
+
+sub tkMenuDup
+{
+ my ($src,$path,$type) = @_;
+ my ($pname,$name) = $path =~ /^(.*)\.([^\.]*)$/;
+ ($name) = $src->PathName =~ /^.*\.([^\.]*)$/ unless $name;
+ my $parent = ($pname) ? $src->Widget($pname) : $src->MainWindow;
+ my %args = (Name => $name, -type => $type);
+ foreach my $option ($src->configure())
+ {
+ next if (@$option == 2);
+ $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]};
+ }
+ my $dst = ref($src)->new($parent,%args);
+ # print "MenuDup $src $path $name $type ->",$dst->PathName,"\n";
+ $_[1] = $dst;
+ if ($type eq 'tearoff')
+ {
+ $dst->transient($parent->toplevel);
+ }
+ my $last = $src->index('last');
+ if ($last ne 'none')
+ {
+ for (my $i = $src->cget('-tearoff'); $i <= $last; $i++)
+ {
+ my $type = $src->type($i);
+ if (defined $type)
+ {
+ my @args = ();
+ foreach my $option ($src->entryconfigure($i))
+ {
+ next if (@$option == 2);
+ push(@args,$$option[0],$$option[4]) if (defined $$option[4]);
+ }
+ $dst->add($type,@args);
+ }
+ }
+ }
+ # Duplicate the binding tags and bindings from the source menu.
+ my @bindtags = $src->bindtags;
+ $path = $src->PathName;
+ foreach (@bindtags)
+ {
+ $_ = $dst if ($_ eq $path);
+ }
+ $dst->bindtags([@bindtags]);
+ foreach my $event ($src->bind)
+ {
+ my $cb = $src->bind($event);
+# print "$event => $cb\n";
+ $dst->bind($event,$cb->Substitute($src,$dst));
+ }
+ return $dst;
+}
+
+
+
+# Some convenience methods
+
+sub separator { require Tk::Menu::Item; shift->Separator(@_); }
+sub cascade { require Tk::Menu::Item; shift->Cascade(@_); }
+sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); }
+sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); }
+
+sub command
+{
+ my ($menu,%args) = @_;
+ require Tk::Menu::Item;
+ if (exists $args{-button})
+ {
+ # Backward compatible stuff from 'Menubar'
+ my $button = delete $args{-button};
+ $button = ['Misc', -underline => 0 ] unless (defined $button);
+ my @bargs = ();
+ ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY');
+ $menu = $menu->Menubutton(-label => $button, @bargs);
+ }
+ $menu->Command(%args);
+}
+
+sub Menubutton
+{
+ my ($menu,%args) = @_;
+ my $name = delete($args{'-text'}) || $args{'-label'};;
+ $args{'-label'} = $name if (defined $name);
+ my $items = delete $args{'-menuitems'};
+ foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill))
+ {
+ delete $args{$opt};
+ }
+ if (defined($name) && !defined($args{-underline}))
+ {
+ my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef;
+ if (defined($underline) && ($underline >= 0))
+ {
+ $args{-underline} = $underline;
+ $args{-label} = $name;
+ }
+ }
+ my $hash = $menu->TkHash('MenuButtons');
+ my $mb = $hash->{$name};
+ if (defined $mb)
+ {
+ delete $args{'-tearoff'}; # too late!
+ $mb->configure(%args) if %args;
+ }
+ else
+ {
+ $mb = $menu->cascade(%args);
+ $hash->{$name} = $mb;
+ }
+ $mb->menu->AddItems(@$items) if defined($items) && @$items;
+ return $mb;
+}
+
+sub BalloonInfo
+{
+ my ($menu,$balloon,$X,$Y,@opt) = @_;
+ my $i = $menu->index('active');
+ if ($i eq 'none')
+ {
+ my $y = $Y - $menu->rooty;
+ $i = $menu->index("\@$y");
+ }
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$menu);
+ if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
+ {
+ $balloon->Subclient($i);
+ return '' if $i eq 'none';
+ return ${$info}[$i] || '';
+ }
+ return $info;
+ }
+}
+
+1;
+
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm
new file mode 100644
index 00000000000..403052ef5bd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm
@@ -0,0 +1,180 @@
+package Tk::Menu::Item;
+
+require Tk::Menu;
+
+use Carp;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $
+
+sub PreInit
+{
+ # Dummy (virtual) method
+ my ($class,$menu,$minfo) = @_;
+}
+
+sub new
+{
+ my ($class,$menu,%minfo) = @_;
+ my $kind = $class->kind;
+ my $name = $minfo{'-label'};
+ if (defined $kind)
+ {
+ my $invoke = delete $minfo{'-invoke'};
+ if (defined $name)
+ {
+ # Use ~ in name/label to set -underline
+ if (defined($minfo{-label}) && !defined($minfo{-underline}))
+ {
+ my $cleanlabel = $minfo{-label};
+ my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef;
+ if (defined($underline) && ($underline >= 0))
+ {
+ $minfo{-underline} = $underline;
+ $name = $cleanlabel if ($minfo{-label} eq $name);
+ $minfo{-label} = $cleanlabel;
+ }
+ }
+ }
+ else
+ {
+ $name = $minfo{'-bitmap'} || $minfo{'-image'};
+ croak('No -label') unless defined($name);
+ $minfo{'-label'} = $name;
+ }
+ $class->PreInit($menu,\%minfo);
+ $menu->add($kind,%minfo);
+ $menu->invoke('last') if ($invoke);
+ }
+ else
+ {
+ $menu->add('separator');
+ }
+ return bless [$menu,$name],$class;
+}
+
+sub configure
+{
+ my $obj = shift;
+ my ($menu,$name) = @$obj;
+ my %args = @_;
+ $obj->[1] = $args{'-label'} if exists $args{'-label'};
+ $menu->entryconfigure($name,@_);
+}
+
+sub cget
+{
+ my $obj = shift;
+ my ($menu,$name) = @$obj;
+ $menu->entrycget($name,@_);
+}
+
+sub parentMenu
+{
+ my $obj = shift;
+ return $obj->[0];
+}
+
+# Default "kind" is a command
+sub kind { return 'command' }
+
+# Now the derived packages
+
+package Tk::Menu::Separator;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Separator';
+sub kind { return undef }
+
+package Tk::Menu::Button;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Button';
+Construct Tk::Menu 'Command';
+
+#package Tk::Menu::Command;
+#use base qw(Tk::Menu::Button);
+#Construct Tk::Menu 'Command';
+
+package Tk::Menu::Cascade;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Cascade';
+sub kind { return 'cascade' }
+use Carp;
+
+sub PreInit
+{
+ my ($class,$menu,$minfo) = @_;
+ my $tearoff = delete $minfo->{-tearoff};
+ my $items = delete $minfo->{-menuitems};
+ my $widgetvar = delete $minfo->{-menuvar};
+ my $command = delete $minfo->{-postcommand};
+ my $name = delete $minfo->{'Name'};
+ $name = $minfo->{'-label'} unless defined $name;
+ my @args = ();
+ push(@args, '-tearoff' => $tearoff) if (defined $tearoff);
+ push(@args, '-menuitems' => $items) if (defined $items);
+ push(@args, '-postcommand' => $command) if (defined $command);
+ my $submenu = $minfo->{'-menu'};
+ unless (defined $submenu)
+ {
+ $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args);
+ }
+ $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar));
+}
+
+sub menu
+{
+ my ($self,%args) = @_;
+ my $w = $self->parentMenu;
+ my $menu = $self->cget('-menu');
+ if (!defined $menu)
+ {
+ require Tk::Menu;
+ $w->ColorOptions(\%args);
+ my $name = $self->cget('-label');
+ warn "Had to (re-)reate menu for $name";
+ $menu = $w->Menu(Name => $name, %args);
+ $self->configure('-menu'=>$menu);
+ }
+ else
+ {
+ $menu->configure(%args) if %args;
+ }
+ return $menu;
+}
+
+# Some convenience methods
+
+sub separator { shift->menu->Separator(@_); }
+sub command { shift->menu->Command(@_); }
+sub cascade { shift->menu->Cascade(@_); }
+sub checkbutton { shift->menu->Checkbutton(@_); }
+sub radiobutton { shift->menu->Radiobutton(@_); }
+
+sub pack
+{
+ my $w = shift;
+ if ($^W)
+ {
+ require Carp;
+ Carp::carp("Cannot 'pack' $w - done automatically")
+ }
+}
+
+package Tk::Menu::Checkbutton;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Checkbutton';
+sub kind { return 'checkbutton' }
+
+package Tk::Menu::Radiobutton;
+use base qw(Tk::Menu::Item);
+Construct Tk::Menu 'Radiobutton';
+sub kind { return 'radiobutton' }
+
+package Tk::Menu::Item;
+
+1;
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menubar.pm b/Master/tlpkg/tlperl/lib/Tk/Menubar.pm
new file mode 100644
index 00000000000..54b745130bf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Menubar.pm
@@ -0,0 +1,15 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Menubar;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Menubar.pm#6 $
+
+use Tk::Frame;
+use Tk::Menu;
+# use Carp;
+# carp "Tk::Menubar is obsolete" if $^W;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm b/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm
new file mode 100644
index 00000000000..59456b2dea2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Menubutton.pm
@@ -0,0 +1,398 @@
+# Converted from menu.tcl --
+#
+# This file defines the default bindings for Tk menus and menubuttons.
+# It also implements keyboard traversal of menus and implements a few
+# other utility procedures related to menus.
+#
+# @(#) menu.tcl 1.34 94/12/19 17:09:09
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+
+package Tk::Menubutton;
+require Tk;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Menubutton/Menubutton.pm#4 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Menubutton';
+
+import Tk qw(&Ev $XS_VERSION);
+
+bootstrap Tk::Menubutton;
+
+sub Tk_cmd { \&Tk::menubutton }
+
+sub InitObject
+{
+ my ($mb,$args) = @_;
+ my $menuitems = delete $args->{-menuitems};
+ my $tearoff = delete $args->{-tearoff};
+ $mb->SUPER::InitObject($args);
+ if ((defined($menuitems) || defined($tearoff)) && %$args)
+ {
+ $mb->configure(%$args);
+ %$args = ();
+ }
+ $mb->menu(-tearoff => $tearoff) if (defined $tearoff);
+ $mb->AddItems(@$menuitems) if (defined $menuitems)
+}
+
+
+#
+#-------------------------------------------------------------------------
+# Elements of tkPriv that are used in this file:
+#
+# cursor - Saves the -cursor option for the posted menubutton.
+# focus - Saves the focus during a menu selection operation.
+# Focus gets restored here when the menu is unposted.
+# inMenubutton - The name of the menubutton widget containing
+# the mouse, or an empty string if the mouse is
+# not over any menubutton.
+# popup - If a menu has been popped up via tk_popup, this
+# gives the name of the menu. Otherwise this
+# value is empty.
+# postedMb - Name of the menubutton whose menu is currently
+# posted, or an empty string if nothing is posted
+# A grab is set on this widget.
+# relief - Used to save the original relief of the current
+# menubutton.
+# window - When the mouse is over a menu, this holds the
+# name of the menu; it's cleared when the mouse
+# leaves the menu.
+#-------------------------------------------------------------------------
+#-------------------------------------------------------------------------
+# Overall note:
+# This file is tricky because there are four different ways that menus
+# can be used:
+#
+# 1. As a pulldown from a menubutton. This is the most common usage.
+# In this style, the variable tkPriv(postedMb) identifies the posted
+# menubutton.
+# 2. As a torn-off menu copied from some other menu. In this style
+# tkPriv(postedMb) is empty, and the top-level menu is no
+# override-redirect.
+# 3. As an option menu, triggered from an option menubutton. In thi
+# style tkPriv(postedMb) identifies the posted menubutton.
+# 4. As a popup menu. In this style tkPriv(postedMb) is empty and
+# the top-level menu is override-redirect.
+#
+# The various binding procedures use the state described above to
+# distinguish the various cases and take different actions in each
+# case.
+#-------------------------------------------------------------------------
+# Menu::Bind --
+# This procedure is invoked the first time the mouse enters a menubutton
+# widget or a menubutton widget receives the input focus. It creates
+# all of the class bindings for both menubuttons and menus.
+#
+# Arguments:
+# w - The widget that was just entered or just received
+# the input focus.
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<FocusIn>','NoOp');
+ $mw->bind($class,'<Enter>','Enter');
+ $mw->bind($class,'<Leave>','Leave');
+ $mw->bind($class,'<1>','ButtonDown');
+ $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]);
+ $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonUp');
+ $mw->bind($class,'<space>','PostFirst');
+ $mw->bind($class,'<Return>','PostFirst');
+ return $class;
+}
+
+sub ButtonDown
+{my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton);
+}
+
+sub PostFirst
+{
+ my $w = shift;
+ my $menu = $w->cget('-menu');
+ $w->Post();
+ $menu->FirstEntry() if (defined $menu);
+}
+
+
+# Enter --
+# This procedure is invoked when the mouse enters a menubutton
+# widget. It activates the widget unless it is disabled. Note:
+# this procedure is only invoked when mouse button 1 is *not* down.
+# The procedure B1Enter is invoked if the button is down.
+#
+# Arguments:
+# w - The name of the widget.
+sub Enter
+{
+ my $w = shift;
+ $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton);
+ $Tk::inMenubutton = $w;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->configure('-state','active')
+ }
+}
+
+sub Leave
+{
+ my $w = shift;
+ $Tk::inMenubutton = undef;
+ return unless Tk::Exists($w);
+ if ($w->cget('-state') eq 'active')
+ {
+ $w->configure('-state','normal')
+ }
+}
+# Post --
+# Given a menubutton, this procedure does all the work of posting
+# its associated menu and unposting any other menu that is currently
+# posted.
+#
+# Arguments:
+# w - The name of the menubutton widget whose menu
+# is to be posted.
+# x, y - Root coordinates of cursor, used for positioning
+# option menus. If not specified, then the center
+# of the menubutton is used for an option menu.
+sub Post
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ return if ($w->cget('-state') eq 'disabled');
+ return if (defined $Tk::postedMb && $w == $Tk::postedMb);
+ my $menu = $w->cget('-menu');
+ return unless (defined($menu) && $menu->index('last') ne 'none');
+
+ my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff';
+
+ my $wpath = $w->PathName;
+ my $mpath = $menu->PathName;
+ unless (index($mpath,"$wpath.") == 0)
+ {
+ die "Cannot post $mpath : not a descendant of $wpath";
+ }
+
+ my $cur = $Tk::postedMb;
+ if (defined $cur)
+ {
+ Tk::Menu->Unpost(undef); # fixme
+ }
+ $Tk::cursor = $w->cget('-cursor');
+ $Tk::relief = $w->cget('-relief');
+ $w->configure('-cursor','arrow');
+ $w->configure('-relief','raised');
+ $Tk::postedMb = $w;
+ $Tk::focus = $w->focusCurrent;
+ $menu->activate('none');
+ $menu->GenerateMenuSelect;
+ # If this looks like an option menubutton then post the menu so
+ # that the current entry is on top of the mouse. Otherwise post
+ # the menu just below the menubutton, as for a pull-down.
+
+ eval
+ {local $SIG{'__DIE__'};
+ my $dir = $w->cget('-direction');
+ if ($dir eq 'above')
+ {
+ $menu->post($w->rootx, $w->rooty - $menu->ReqHeight);
+ }
+ elsif ($dir eq 'below')
+ {
+ $menu->post($w->rootx, $w->rooty + $w->Height);
+ }
+ elsif ($dir eq 'left')
+ {
+ my $x = $w->rootx - $menu->ReqWidth;
+ my $y = int((2*$w->rooty + $w->Height) / 2);
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($x,$y);
+ }
+ }
+ elsif ($dir eq 'right')
+ {
+ my $x = $w->rootx + $w->Width;
+ my $y = int((2*$w->rooty + $w->Height) / 2);
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($x,$y);
+ }
+ }
+ else
+ {
+ if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
+ {
+ if (!defined($y))
+ {
+ $x = $w->rootx+$w->width/2;
+ $y = $w->rooty+$w->height/2
+ }
+ $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
+ }
+ else
+ {
+ $menu->post($w->rootx,$w->rooty+$w->height);
+ }
+ }
+ };
+ if ($@)
+ {
+ Tk::Menu->Unpost;
+ die $@
+ }
+
+ $Tk::tearoff = $tearoff;
+ if ($tearoff)
+ {
+ $menu->focus;
+ $w->SaveGrabInfo;
+ $w->grabGlobal;
+ }
+}
+# Motion --
+# This procedure handles mouse motion events inside menubuttons, and
+# also outside menubuttons when a menubutton has a grab (e.g. when a
+# menu selection operation is in progress).
+#
+# Arguments:
+# w - The name of the menubutton widget.
+# upDown - "down" means button 1 is pressed, "up" means
+# it isn't.
+# rootx, rooty - Coordinates of mouse, in (virtual?) root window.
+sub Motion
+{
+ my $w = shift;
+ my $upDown = shift;
+ my $rootx = shift;
+ my $rooty = shift;
+ return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w);
+ my $new = $w->Containing($rootx,$rooty);
+ if (defined($Tk::inMenubutton))
+ {
+ if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel))
+ {
+ $Tk::inMenubutton->Leave();
+ }
+ }
+ if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 &&
+ $w->cget('-indicatoron') == 0)
+ {
+ if ($upDown eq 'down')
+ {
+ $new->Post($rootx,$rooty);
+ }
+ else
+ {
+ $new->Enter();
+ }
+ }
+}
+# ButtonUp --
+# This procedure is invoked to handle button 1 releases for menubuttons.
+# If the release happens inside the menubutton then leave its menu
+# posted with element 0 activated. Otherwise, unpost the menu.
+#
+# Arguments:
+# w - The name of the menubutton widget.
+
+sub ButtonUp {
+ my $w = shift;
+
+ my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) &&
+ $w->cget('-menu')->cget('-type') eq 'tearoff');
+ if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w)
+ && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) {
+ $Tk::postedMb->cget(-menu)->FirstEntry();
+ } else {
+ Tk::Menu->Unpost(undef);
+ }
+} # end ButtonUp
+
+# Some convenience methods
+
+sub menu
+{
+ my ($w,%args) = @_;
+ my $menu = $w->cget('-menu');
+ if (!defined $menu)
+ {
+ require Tk::Menu;
+ $w->ColorOptions(\%args) if ($Tk::platform eq 'unix');
+ $menu = $w->Menu(%args);
+ $w->configure('-menu'=>$menu);
+ }
+ else
+ {
+ $menu->configure(%args);
+ }
+ return $menu;
+}
+
+sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); }
+sub command { require Tk::Menu::Item; shift->menu->Command(@_); }
+sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); }
+sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); }
+sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); }
+
+sub AddItems
+{
+ shift->menu->AddItems(@_);
+}
+
+sub entryconfigure
+{
+ shift->menu->entryconfigure(@_);
+}
+
+sub entrycget
+{
+ shift->menu->entrycget(@_);
+}
+
+sub FindMenu
+{
+ my $child = shift;
+ my $char = shift;
+ my $ul = $child->cget('-underline');
+ if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled')
+ {
+ my $char2 = $child->cget('-text');
+ $char2 = substr("\L$char2",$ul,1) if (defined $char2);
+ if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2))
+ {
+ $child->PostFirst;
+ return $child;
+ }
+ }
+ return undef;
+}
+
+1;
+
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Message.pm b/Master/tlpkg/tlperl/lib/Tk/Message.pm
new file mode 100644
index 00000000000..63b0f170097
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Message.pm
@@ -0,0 +1,20 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Message;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Message.pm#6 $
+
+require Tk::Widget;
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Message';
+
+sub Tk_cmd { \&Tk::message }
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm b/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm
new file mode 100644
index 00000000000..0e45251f852
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/NBFrame.pm
@@ -0,0 +1,20 @@
+package Tk::NBFrame;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/NBFrame/NBFrame.pm#4 $
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'NBFrame';
+
+bootstrap Tk::NBFrame;
+
+sub Tk_cmd { \&Tk::nbframe }
+
+Tk::Methods qw(activate add delete focus info geometryinfo identify
+ move pagecget pageconfigure);
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm b/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm
new file mode 100644
index 00000000000..64db87a80d3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/NoteBook.pm
@@ -0,0 +1,452 @@
+package Tk::NoteBook;
+#
+# Implementation of NoteBook widget.
+# Derived from NoteBook.tcl in Tix 4.0
+
+# Contributed by Rajappa Iyer <rsi@earthling.net>
+# Hacked by Nick for 'menu' traversal.
+# Restructured by Nick
+
+use vars qw($VERSION);
+
+$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+require Tk::NBFrame;
+
+use base qw(Tk::Derived Tk::NBFrame);
+Tk::Widget->Construct('NoteBook');
+use strict;
+
+use Tk qw(Ev);
+
+use Carp;
+require Tk::Frame;
+
+sub TraverseToNoteBook;
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ # class binding does not work right due to extra level of
+ # widget hierachy
+ $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Left>', ['FocusNext','prev']);
+ $mw->bind($class,'<Right>', ['FocusNext','next']);
+
+ $mw->bind($class,'<Return>', 'SetFocusByKey');
+ $mw->bind($class,'<space>', 'SetFocusByKey');
+ return $class;
+}
+
+sub raised
+{
+ return shift->{'topchild'};
+}
+
+sub Populate
+{
+ my ($w, $args) = @_;
+
+ $w->SUPER::Populate($args);
+ $w->{'pad-x1'} = undef;
+ $w->{'pad-x2'} = undef;
+ $w->{'pad-y1'} = undef;
+ $w->{'pad-y2'} = undef;
+
+ $w->{'windows'} = [];
+ $w->{'nWindows'} = 0;
+ $w->{'minH'} = 1;
+ $w->{'minW'} = 1;
+
+ $w->{'counter'} = 0;
+ $w->{'resize'} = 0;
+
+ $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
+ -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
+ -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
+ -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
+
+ # SetBindings
+ $w->bind('<Configure>','MasterGeomProc');
+
+ $args->{-slave} = 1;
+ $args->{-takefocus} = 1;
+ $args->{-relief} = 'raised';
+
+ $w->QueueResize;
+}
+
+
+#---------------------------
+# Public methods
+#---------------------------
+
+sub page_widget
+{
+ my $w = shift;
+ $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
+ my $h = $w->{'_pages_'};
+ if (@_)
+ {
+ my $name = shift;
+ if (@_)
+ {
+ my $cw = shift;
+ if (defined $cw)
+ {
+ $h->{$name} = $cw;
+ }
+ else
+ {
+ return delete $h->{$name};
+ }
+ }
+ return $h->{$name};
+ }
+ else
+ {
+ return (values %$h);
+ }
+}
+
+sub add
+{
+ my ($w, $child, %args) = @_;
+
+ croak("$child already exists") if defined $w->page_widget($child);
+
+ my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
+
+ my $ccmd = delete $args{-createcmd};
+ my $rcmd = delete $args{-raisecmd};
+ $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
+ $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
+
+ # manage our geometry
+ $w->ManageGeometry($f);
+ # create default bindings
+ $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
+ $f->bind('<Destroy>', [$w,'delete',$child,1]);
+ $w->page_widget($child,$f);
+ $w->{'nWindows'}++;
+ push(@{$w->{'windows'}}, $child);
+ $w->SUPER::add($child,%args);
+ return $f;
+}
+
+sub raise
+{
+ my ($w, $child) = @_;
+ return unless defined $child;
+ if ($w->pagecget($child, -state) eq 'normal')
+ {
+ $w->activate($child);
+ $w->focus($child);
+ my $childw = $w->page_widget($child);
+ if ($childw)
+ {
+ if (defined $childw->{-createcmd})
+ {
+ $childw->{-createcmd}->Call($childw);
+ delete $childw->{-createcmd};
+ }
+ # hide the original visible window
+ my $oldtop = $w->{'topchild'};
+ if (defined($oldtop) && ($oldtop ne $child))
+ {
+ $w->page_widget($oldtop)->UnmapWindow;
+ }
+ $w->{'topchild'} = $child;
+ my $myW = $w->Width;
+ my $myH = $w->Height;
+
+ if (!defined $w->{'pad-x1'}) {
+ $w->InitTabSize;
+ }
+
+ my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
+ my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
+
+ if ($cW > 0 && $cH > 0)
+ {
+ $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
+ $childw->MapWindow;
+ $childw->raise;
+ }
+ if ((not defined $oldtop) || ($oldtop ne $child))
+ {
+ if (defined $childw->{-raisecmd})
+ {
+ $childw->{-raisecmd}->Call($childw);
+ }
+ }
+ }
+ }
+}
+
+sub pageconfigure
+{
+ my ($w, $child, %args) = @_;
+ my $childw = $w->page_widget($child);
+ if (defined $childw)
+ {
+ my $ccmd = delete $args{-createcmd};
+ my $rcmd = delete $args{-raisecmd};
+ $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
+ $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
+ $w->SUPER::pageconfigure($child, %args) if (keys %args);
+ }
+}
+
+sub pages {
+ my ($w) = @_;
+ return @{$w->{'windows'}};
+}
+
+sub pagecget
+{
+ my ($w, $child, $opt) = @_;
+ my $childw = $w->page_widget($child);
+ if (defined $childw)
+ {
+ return $childw->{-createcmd} if ($opt =~ /-createcmd/);
+ return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
+ return $w->SUPER::pagecget($child, $opt);
+ }
+ else
+ {
+ carp "page $child does not exist";
+ }
+}
+
+sub delete
+{
+ my ($w, $child, $destroy) = @_;
+ my $childw = $w->page_widget($child,undef);
+ if (defined $childw)
+ {
+ $childw->bind('<Destroy>', undef);
+ $childw->destroy;
+ @{$w->{'windows'}} = grep($_ !~ /$child/, @{$w->{'windows'}});
+ $w->{'nWindows'}--;
+ $w->SUPER::delete($child);
+ # see if the child to be deleted was the top child
+ if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
+ {
+ delete $w->{'topchild'};
+ if ( @{$w->{'windows'}})
+ {
+ $w->raise($w->{'windows'}[0]);
+ }
+ }
+ }
+ else
+ {
+ carp "page $child does not exist" unless $destroy;
+ }
+}
+
+#---------------------------------------
+# Private methods
+#---------------------------------------
+
+sub MouseDown {
+ my ($w, $x, $y) = @_;
+ my $name = $w->identify($x, $y);
+ $w->focus($name);
+ $w->{'down'} = $name;
+}
+
+sub MouseUp {
+ my ($w, $x, $y) = @_;
+ my $name = $w->identify($x, $y);
+ if ((defined $name) && (defined $w->{'down'}) &&
+ ($name eq $w->{'down'}) &&
+ ($w->pagecget($name, -state) eq 'normal')) {
+ $w->raise($name);
+ } else {
+ $w->focus($name);
+ }
+}
+
+sub FocusNext {
+ my ($w, $dir) = @_;
+ my $name;
+
+ if (not defined $w->info('focus')) {
+ $name = $w->info('active');
+ $w->focus($name);
+ } else {
+ $name = $w->info('focus' . $dir);
+ $w->focus($name);
+ }
+}
+
+sub SetFocusByKey {
+ my ($w) = @_;
+
+ my $name = $w->info('focus');
+ if (defined $name) {
+ if ($w->pagecget($name, -state) eq 'normal') {
+ $w->raise($name);
+ $w->activate($name);
+ }
+ }
+}
+
+sub NoteBookFind {
+ my ($w, $char) = @_;
+
+ my $page;
+ foreach $page (@{$w->{'windows'}}) {
+ my $i = $w->pagecget($page, -underline);
+ my $c = substr($page, $i, 1);
+ if ($char =~ /$c/) {
+ if ($w->pagecget($page, -state) ne 'disabled') {
+ return $page;
+ }
+ }
+ }
+ return undef;
+}
+
+# This is called by TraveseToMenu when an <Alt-Keypress> occurs
+# See the code in Tk.pm
+sub FindMenu {
+ my ($w, $char) = @_;
+
+ my $page;
+ foreach $page (@{$w->{'windows'}}) {
+ my $i = $w->pagecget($page, -underline);
+ my $l = $w->pagecget($page, -label);
+ next if (not defined $l);
+ my $c = substr($l, $i, 1);
+ if ($char =~ /$c/i) {
+ if ($w->pagecget($page, -state) ne 'disabled') {
+ $w->raise($page);
+ return $w;
+ }
+ }
+ }
+ return undef;
+}
+
+
+sub MasterGeomProc
+{
+ my ($w) = @_;
+ if (Tk::Exists($w))
+ {
+ $w->{'resize'} = 0 unless (defined $w->{'resize'});
+ $w->QueueResize;
+ }
+}
+
+sub SlaveGeometryRequest
+{
+ my $w = shift;
+ if (Tk::Exists($w))
+ {
+ $w->QueueResize;
+ }
+}
+
+sub LostSlave {
+ my ($w, $s) = @_;
+ $s->UnmapWindow;
+}
+
+sub ClientGeomProc
+{
+ my ($w, $flag, $client) = @_;
+ $w->QueueResize if (Tk::Exists($w));
+ if ($flag =~ /-lostslave/)
+ {
+ carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
+ }
+}
+
+sub QueueResize
+{
+ my $w = shift;
+ $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
+}
+
+sub Resize {
+
+ my ($w) = @_;
+
+ return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
+
+ $w->InitTabSize;
+
+ $w->{'resize'} = 0;
+ my $reqW = $w->{-width} || 0;
+ my $reqH = $w->{-height} || 0;
+
+ if ($reqW * $reqH == 0)
+ {
+ if ((not defined $w->{-dynamicgeometry}) ||
+ ($w->{-dynamicgeometry} == 0)) {
+ $reqW = 1;
+ $reqH = 1;
+
+ my $childw;
+ foreach $childw ($w->page_widget)
+ {
+ my $cW = $childw->ReqWidth;
+ my $cH = $childw->ReqHeight;
+ $reqW = $cW if ($reqW < $cW);
+ $reqH = $cH if ($reqH < $cH);
+ }
+ } else {
+ if (defined $w->{'topchild'}) {
+ my $topw = $w->page_widget($w->{'topchild'});
+ $reqW = $topw->ReqWidth;
+ $reqH = $topw->ReqHeight;
+ } else {
+ $reqW = 1;
+ $reqH = 1;
+ }
+ }
+ $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
+ $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
+ $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'};
+ $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'};
+ }
+ if (($w->ReqWidth != $reqW) ||
+ ($w->ReqHeight != $reqH)) {
+ $w->{'counter'} = 0 if (not defined $w->{'counter'});
+ if ($w->{'counter'} < 50) {
+ $w->{'counter'}++;
+ $w->GeometryRequest($reqW, $reqH);
+ $w->afterIdle([$w,'Resize']);
+ $w->{'resize'} = 1;
+ return;
+ }
+ }
+ $w->{'counter'} = 0;
+ $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]);
+ $w->{'resize'} = 0;
+}
+
+sub InitTabSize {
+ my ($w) = @_;
+ my ($tW, $tH) = $w->geometryinfo;
+ $w->{'pad-x1'} = 2;
+ $w->{'pad-x2'} = 2;
+ $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
+ $w->{'pad-y2'} = 2;
+ $w->{'minW'} = $tW;
+ $w->{'minH'} = $tH;
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm b/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm
new file mode 100644
index 00000000000..7c0e81766db
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Optionmenu.pm
@@ -0,0 +1,130 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Optionmenu;
+require Tk::Menubutton;
+require Tk::Menu;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/Optionmenu.pm#13 $
+
+use base qw(Tk::Derived Tk::Menubutton);
+
+use strict;
+
+Construct Tk::Widget 'Optionmenu';
+
+sub Populate
+{
+ my ($w,$args) = @_;
+ $w->SUPER::Populate($args);
+ $args->{-indicatoron} = 1;
+ my $menu = $w->menu(-tearoff => 0);
+
+ # Should we allow -menubackground etc. as in -label* of Frame ?
+
+ $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef],
+ -options => ['METHOD', undef, undef, undef],
+ -variable=> ['PASSIVE', undef, undef, undef],
+ -font => [['SELF',$menu], undef, undef, undef],
+ -foreground => [['SELF', 'CHILDREN'], undef, undef, undef],
+
+ -takefocus => [ qw/SELF takefocus Takefocus 1/ ],
+ -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ],
+ -relief => [ qw/SELF relief Relief raised/ ],
+
+ );
+
+ # configure -variable and -command now so that when -options
+ # is set by main-line configure they are there to be set/called.
+
+ my $tvar = delete $args->{-textvariable};
+ my $vvar = delete $args->{-variable};
+ if (!defined($vvar))
+ {
+ if (defined $tvar)
+ {
+ $vvar = $tvar;
+ }
+ else
+ {
+ my $new;
+ $vvar = \$new;
+ }
+ }
+ $tvar = $vvar if (!defined($tvar));
+ $w->configure(-textvariable => $tvar, -variable => $vvar);
+ $w->configure(-command => $vvar) if ($vvar = delete $args->{-command});
+}
+
+sub setOption
+{
+ my ($w, $label, $val) = @_;
+ my $tvar = $w->cget(-textvariable);
+ my $vvar = $w->cget(-variable);
+ if (@_ == 2)
+ {
+ $val = $label;
+ }
+ $$tvar = $label if $tvar;
+ $$vvar = $val if $vvar;
+ $w->Callback(-command => $val);
+}
+
+sub addOptions
+{
+ my $w = shift;
+ my $menu = $w->menu;
+ my $tvar = $w->cget(-textvariable);
+ my $vvar = $w->cget(-variable);
+ my $oldt = $$tvar;
+ my $width = $w->cget('-width');
+ my %hash;
+ my $first;
+ while (@_)
+ {
+ my $val = shift;
+ my $label = $val;
+ if (ref $val)
+ {
+ if ($vvar == $tvar)
+ {
+ my $new = $label;
+ $w->configure(-textvariable => ($tvar = \$new));
+ }
+ ($label, $val) = @$val;
+ }
+ my $len = length($label);
+ $width = $len if (!defined($width) || $len > $width);
+ $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]);
+ $hash{$label} = $val;
+ $first = $label unless defined $first;
+ }
+ if (!defined($oldt) || !exists($hash{$oldt}))
+ {
+ $w->setOption($first, $hash{$first}) if defined $first;
+ }
+ $w->configure('-width' => $width);
+}
+
+sub options
+{
+ my ($w,$opts) = @_;
+ if (@_ > 1)
+ {
+ $w->menu->delete(0,'end');
+ $w->addOptions(@$opts);
+ }
+ else
+ {
+ return $w->_cget('-options');
+ }
+}
+
+1;
+
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/PNG.pm b/Master/tlpkg/tlperl/lib/Tk/PNG.pm
new file mode 100644
index 00000000000..1ecb4001d17
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/PNG.pm
@@ -0,0 +1,43 @@
+package Tk::PNG;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/;
+
+use Tk 800.005;
+require Tk::Image;
+require Tk::Photo;
+
+use base qw(DynaLoader);
+
+bootstrap Tk::PNG $Tk::VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::PNG - PNG loader for Tk::Photo
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::PNG;
+
+ my $image = $widget->Photo('-format' => 'png', -file => 'something.png');
+
+
+=head1 DESCRIPTION
+
+This is an extension for Tk800.* which supplies
+PNG format loader for Photo image type.
+
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Pane.pm b/Master/tlpkg/tlperl/lib/Tk/Pane.pm
new file mode 100644
index 00000000000..36c5203a42d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Pane.pm
@@ -0,0 +1,544 @@
+# Tk::Pane.pm
+#
+# Copyright (c) 1997-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::Pane;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Pane.pm#7 $
+
+use Tk;
+use Tk::Widget;
+use Tk::Derived;
+use Tk::Frame;
+
+use strict;
+
+use base qw(Tk::Derived Tk::Frame);
+
+Construct Tk::Widget 'Pane';
+
+use Tk::Submethods(
+ grid => [qw/bbox columnconfigure location propagate rowconfigure size slaves/],
+ pack => [qw/propagate slaves/]
+);
+
+sub ClassInit {
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',4]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ return $class;
+}
+
+sub Populate {
+ my $pan = shift;
+
+ my $frame = $pan->Component(Frame => "frame");
+
+ $pan->afterIdle(['Manage',$pan,$frame]);
+ $pan->afterIdle(['QueueLayout',$pan,1]);
+
+ $pan->Delegates(
+ DEFAULT => $frame,
+ # FIXME
+ # These are a hack to avoid an existing bug in Tk::Widget::DelegateFor
+ # which has been reported and should be fixed in the next Tk release
+ see => $pan,
+ xview => $pan,
+ yview => $pan,
+ );
+
+ $pan->ConfigSpecs(
+ DEFAULT => [$frame],
+ -sticky => [PASSIVE => undef, undef, undef],
+ -gridded => [PASSIVE => undef, undef, undef],
+ -xscrollcommand => [CALLBACK => undef, undef, undef],
+ -yscrollcommand => [CALLBACK => undef, undef, undef],
+ );
+
+
+ $pan;
+}
+
+
+sub grid {
+ my $w = shift;
+ $w = $w->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?: bbox
+ |columnconfigure
+ |location
+ |propagate
+ |rowconfigure
+ |size
+ |slaves)$/x);
+ $w->SUPER::grid(@_);
+}
+
+sub slave {
+ my $w = shift;
+ $w->Subwidget('frame');
+}
+
+sub pack {
+ my $w = shift;
+ $w = $w->Subwidget('frame')
+ if (@_ && $_[0] =~ /^(?:propagate|slaves)$/x);
+ $w->SUPER::pack(@_);
+}
+
+sub QueueLayout {
+ shift if ref $_[1];
+ my($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub AdjustXY {
+ my($w,$Wref,$X,$st,$scrl,$getx) = @_;
+ my $W = $$Wref;
+
+ if($w >= $W) {
+ my $v = 0;
+ if($getx) {
+ $v |= 1 if $st =~ /[Ww]/;
+ $v |= 2 if $st =~ /[Ee]/;
+ }
+ else {
+ $v |= 1 if $st =~ /[Nn]/;
+ $v |= 2 if $st =~ /[Ss]/;
+ }
+
+ if($v == 0) {
+ $X = int(($w - $W) / 2);
+ }
+ elsif($v == 1) {
+ $X = 0;
+ }
+ elsif($v == 2) {
+ $X = int($w - $W);
+ }
+ else {
+ $X = 0;
+ $$Wref = $w;
+ }
+ $scrl->Call(0,1)
+ if $scrl;
+ }
+ elsif($scrl) {
+ $X = 0
+ if $X > 0;
+ $X = $w - $W
+ if(($X + $W) < $w);
+ $scrl->Call(-$X / $W,(-$X + $w) / $W);
+ }
+ else {
+ $X = 0;
+ $$Wref = $w;
+ }
+
+ return $X;
+}
+
+sub Layout {
+ my $pan = shift;
+ my $why = $pan->{LayoutPending};
+
+ my $slv = $pan->Subwidget('frame');
+
+ return unless $slv;
+
+ my $H = $slv->ReqHeight;
+ my $W = $slv->ReqWidth;
+ my $X = $slv->x;
+ my $Y = $slv->y;
+ my $w = $pan->width;
+ my $h = $pan->height;
+ my $yscrl = $pan->{Configure}{'-yscrollcommand'};
+ my $xscrl = $pan->{Configure}{'-xscrollcommand'};
+
+ $yscrl = undef
+ if(defined($yscrl) && UNIVERSAL::isa($yscrl, 'SCALAR') && !defined($$yscrl));
+ $xscrl = undef
+ if(defined($xscrl) && UNIVERSAL::isa($xscrl, 'SCALAR') && !defined($$xscrl));
+
+ if($why & 1) {
+ $h = $pan->{Configure}{'-height'} || 0
+ unless($h > 1);
+ $w = $pan->{Configure}{'-width'} || 0
+ unless($w > 1);
+
+ $h = $H
+ unless($h > 1 || defined($yscrl));
+ $w = $W
+ unless($w > 1 || defined($xscrl));
+
+ $w = 100 if $w <= 1;
+ $h = 100 if $h <= 1;
+
+ $pan->GeometryRequest($w,$h);
+ }
+
+ my $st = $pan->{Configure}{'-sticky'} || '';
+
+ $pan->{LayoutPending} = 0;
+
+ $slv->MoveResizeWindow(
+ AdjustXY($w,\$W,$X,$st,$xscrl,1),
+ AdjustXY($h,\$H,$Y,$st,$yscrl,0),
+ $W,$H
+ );
+}
+
+sub SlaveGeometryRequest {
+ my ($m,$s) = @_;
+ $m->QueueLayout(1);
+}
+
+sub LostSlave {
+ my($m,$s) = @_;
+ $m->{Slave} = undef;
+}
+
+sub Manage {
+ my $m = shift;
+ my $s = shift;
+
+ $m->{Slave} = $s;
+ $m->ManageGeometry($s);
+ $s->MapWindow;
+ $m->QueueLayout(2);
+}
+
+sub xview {
+ my $pan = shift;
+
+ unless(@_) {
+ my $scrl = $pan->{Configure}{'-xscrollcommand'};
+ return (0,1) unless $scrl;
+ my $slv = $pan->Subwidget('frame');
+ my $sw = $slv->ReqWidth;
+ my $ldx = $pan->rootx - $slv->rootx;
+ my $rdx = $ldx + $pan->width;
+ $ldx = $ldx <= 0 ? 0 : $ldx / $sw;
+ $rdx = $rdx >= $sw ? 1 : $rdx / $sw;
+ return( $ldx , $rdx);
+ }
+ elsif(@_ == 1) {
+ my $widget = shift;
+ my $slv = $pan->Subwidget('frame');
+ xyview(1,$pan,
+ moveto => ($widget->rootx - $slv->rootx) / $slv->ReqWidth);
+ }
+ else {
+ xyview(1,$pan,@_);
+ }
+}
+
+sub yview {
+ my $pan = shift;
+
+ unless(@_) {
+ my $scrl = $pan->{Configure}{'-yscrollcommand'};
+ return (0,1) unless $scrl;
+ my $slv = $pan->Subwidget('frame');
+ my $sh = $slv->ReqHeight;
+ my $tdy = $pan->rooty - $slv->rooty;
+ my $bdy = $tdy + $pan->height;
+ $tdy = $tdy <= 0 ? 0 : $tdy / $sh;
+ $bdy = $bdy >= $sh ? 1 : $bdy / $sh;
+ return( $tdy, $bdy);
+ }
+ elsif(@_ == 1) {
+ my $widget = shift;
+ my $slv = $pan->Subwidget('frame');
+ xyview(0,$pan,
+ moveto => ($widget->rooty - $slv->rooty) / $slv->ReqHeight);
+ }
+ else {
+ xyview(0,$pan,@_);
+ }
+}
+
+sub xyview {
+ my($horz,$pan,$cmd,$val,$mul) = @_;
+ my $slv = $pan->Subwidget('frame');
+ return unless $slv;
+
+ my($XY,$WH,$wh,$scrl,@a);
+
+ if($horz) {
+ $XY = $slv->x;
+ $WH = $slv->ReqWidth;
+ $wh = $pan->width;
+ $scrl = $pan->{Configure}{'-xscrollcommand'};
+ }
+ else {
+ $XY = $slv->y;
+ $WH = $slv->ReqHeight;
+ $wh = $pan->height;
+ $scrl = $pan->{Configure}{'-yscrollcommand'};
+ }
+
+ $scrl = undef
+ if(UNIVERSAL::isa($scrl, 'SCALAR') && !defined($$scrl));
+
+ if($WH < $wh) {
+ $scrl->Call(0,1);
+ return;
+ }
+
+ if($cmd eq 'scroll') {
+ my $dxy = 0;
+
+ my $gridded = $pan->{Configure}{'-gridded'} || '';
+ my $do_gridded = ($gridded eq 'both'
+ || (!$horz == ($gridded ne 'x'))) ? 1 : 0;
+
+ if($do_gridded && $mul eq 'pages') {
+ my $ch = ($slv->children)[0];
+ if(defined($ch) && $ch->manager eq 'grid') {
+ @a = $horz
+ ? (1-$XY,int($slv->width / 2))
+ : (int($slv->height / 2),1-$XY);
+ my $rc = ($slv->gridLocation(@a))[$horz ? 0 : 1];
+ my $mrc = ($slv->gridSize)[$horz ? 0 : 1];
+ $rc += $val;
+ $rc = 0 if $rc < 0;
+ $rc = $mrc if $rc > $mrc;
+ my $gsl;
+ while($rc >= 0 && $rc < $mrc) {
+ $gsl = ($slv->gridSlaves(-row => $rc))[0];
+ last
+ if defined $gsl;
+ $rc += $val;
+ }
+ if(defined $gsl) {
+ @a = $horz ? ($rc,0) : (0,$rc);
+ $XY = 0 - ($slv->gridBbox(@a))[$horz ? 0 : 1];
+ }
+ else {
+ $XY = $val > 0 ? $wh - $WH : 0;
+ }
+ $dxy = $val; $val = 0;
+ }
+ }
+ $dxy = $mul eq 'pages' ? ($horz ? $pan->width : $pan->height) : 10
+ unless $dxy;
+ $XY -= $dxy * $val;
+ }
+ elsif($cmd eq 'moveto') {
+ $XY = -int($WH * $val);
+ }
+
+ $XY = $wh - $WH
+ if($XY < ($wh - $WH));
+ $XY = 0
+ if $XY > 0;
+
+ @a = $horz
+ ? ( $XY, $slv->y)
+ : ($slv->x, $XY);
+
+ $slv->MoveWindow(@a);
+
+ $scrl->Call(-$XY / $WH,(-$XY + $wh) / $WH);
+}
+
+sub see {
+ my $pan = shift;
+ my $widget = shift;
+ my %opt = @_;
+ my $slv = $pan->Subwidget('frame');
+
+ my $anchor = defined $opt{'-anchor'} ? $opt{'-anchor'} : "";
+
+ if($pan->{Configure}{'-yscrollcommand'}) {
+ my $yanchor = lc(($anchor =~ /([NnSs]?)/)[0] || "");
+ my $pty = $pan->rooty;
+ my $ph = $pan->height;
+ my $pby = $pty + $ph;
+ my $ty = $widget->rooty;
+ my $wh = $widget->height;
+ my $by = $ty + $wh;
+ my $h = $slv->ReqHeight;
+
+ if($yanchor eq 'n' || ($yanchor ne 's' && ($wh >= $h || $ty < $pty))) {
+ my $y = $ty - $slv->rooty;
+ $pan->yview(moveto => $y / $h);
+ }
+ elsif($yanchor eq 's' || $by > $pby) {
+ my $y = $by - $ph - $slv->rooty;
+ $pan->yview(moveto => $y / $h);
+ }
+ }
+
+ if($pan->{Configure}{'-xscrollcommand'}) {
+ my $xanchor = lc(($anchor =~ /([WwEe]?)/)[0] || "");
+ my $ptx = $pan->rootx;
+ my $pw = $pan->width;
+ my $pbx = $ptx + $pw;
+ my $tx = $widget->rootx;
+ my $ww = $widget->width;
+ my $bx = $tx + $ww;
+ my $w = $slv->ReqWidth;
+
+ if($xanchor eq 'w' || ( $xanchor ne 'e' && ($ww >= $w || $tx < $ptx))) {
+ my $x = $tx - $slv->rootx;
+ $pan->xview(moveto => $x / $w);
+ }
+ elsif($xanchor eq 'e' || $bx > $pbx) {
+ my $x = $bx - $pw - $slv->rootx;
+ $pan->xview(moveto => $x / $w);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::Pane - A window panner
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::Pane;
+
+ $pane = $mw->Scrolled(Pane, Name => 'fred',
+ -scrollbars => 'soe',
+ -sticky => 'we',
+ -gridded => 'y'
+ );
+
+ $pane->Frame;
+
+ $pane->pack;
+
+=head1 DESCRIPTION
+
+B<Tk::Pane> provides a scrollable frame widget. Once created it can be
+treated as a frame, except it is scrollable.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-gridded> =E<gt> I<direction>
+
+Specifies if the top and left edges of the pane should snap to a
+grid column. This option is only useful if the widgets in the pane
+are managed by the I<grid> geometry manager. Possible values are
+B<x>, B<y> and B<xy>.
+
+=item B<-sticky> =E<gt> I<style>
+
+If Pane is larger than its requested dimensions, this option may be used to
+position (or stretch) the slave within its cavity. I<Style> is a string that
+contains zero or more of the characters n, s, e or w. The string can optionally
+contains spaces or commas, but they are ignored. Each letter refers to a side
+(north, south, east, or west) that the slave will "stick" to. If both n and s
+(or e and w) are specified, the slave will be stretched to fill the entire
+height (or width) of its cavity.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item I<$pane>-E<gt>B<see>(I<$widget> ?,I<options>?)
+
+Adjusts the view so that I<$widget> is visable. Aditional parameters in
+I<options-value> pairs can be passed, each I<option-value> pair must be
+one of the following
+
+=over 8
+
+=item B<-anchor> =E<gt> I<anchor>
+
+Specifies how to make the widget visable. If not given then as much of
+the widget as possible is made visable.
+
+Possible values are B<n>, B<s>, B<w>, B<e>, B<nw>, B<ne>, B<sw> and B<se>.
+This will cause an edge on the widget to be aligned with the corresponding
+edge on the pane. for example B<nw> will cause the top left of the widget
+to be placed at the top left of the pane. B<s> will cause the bottom of the
+widget to be placed at the bottom of the pane, and as much of the widget
+as possible made visable in the x direction.
+
+=back
+
+=item I<$pane>-E<gt>B<xview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1. The first element gives the position of the left of the
+window, relative to the Pane as a whole (0.5 means it is halfway through the
+Pane, for example). The second element gives the position of the right of the
+window, relative to the Pane as a whole.
+
+=item I<$pane>-E<gt>B<xview>(I<$widget>)
+
+Adjusts the view in the window so that I<widget> is displayed at the left of
+the window.
+
+=item I<$pane>-E<gt>B<xview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total width of the
+Pane is off-screen to the left. fraction must be a fraction between 0 and 1.
+
+=item I<$pane>-E<gt>B<xview>(B<scroll> =E<gt> I<number>, I<what>)
+
+This command shifts the view in the window left or right according to I<number>
+and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
+B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
+adjusts left or right by I<number>*10 screen units on the display; if it is
+B<pages> then the view adjusts by number screenfuls. If number is negative then
+widgets farther to the left become visible; if it is positive then widgets
+farther to the right become visible.
+
+=item I<$pane>-E<gt>B<yview>
+
+Returns a list containing two elements, both of which are real fractions
+between 0 and 1. The first element gives the position of the top of the
+window, relative to the Pane as a whole (0.5 means it is halfway through the
+Pane, for example). The second element gives the position of the bottom of the
+window, relative to the Pane as a whole.
+
+=item I<$pane>-E<gt>B<yview>(I<$widget>)
+
+Adjusts the view in the window so that I<widget> is displayed at the top of the
+window.
+
+=item I<$pane>-E<gt>B<yview>(B<moveto> =E<gt> I<fraction>)
+
+Adjusts the view in the window so that I<fraction> of the total width of the
+Pane is off-screen to the top. fraction must be a fraction between 0 and 1.
+
+=item I<$pane>-E<gt>B<yview>(B<scroll> =E<gt> I<number>, I<what>)
+
+This command shifts the view in the window up or down according to I<number>
+and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
+B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
+adjusts up or down by I<number>*10 screen units on the display; if it is
+B<pages> then the view adjusts by number screenfuls. If number is negative then
+widgets farther up become visible; if it is positive then widgets farther down
+become visible.
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm
new file mode 100644
index 00000000000..d984b648897
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm
@@ -0,0 +1,221 @@
+package Tk::Panedwindow;
+use strict;
+
+use vars qw/$VERSION/;
+$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /#(\d+)/;
+
+# A Panedwindow widget (similar to Adjuster).
+
+use Tk qw/Ev/;
+use base qw/Tk::Widget/;
+
+Construct Tk::Widget 'Panedwindow';
+
+sub Tk_cmd { \&Tk::panedwindow }
+
+Tk::Methods('add', 'forget', 'identify', 'proxy', 'sash', 'panes');
+
+use Tk::Submethods (
+ 'proxy' => [qw/coord forget place/],
+ 'sash' => [qw/coord mark place/],
+);
+
+sub ClassInit {
+
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class, '<Button-1>' => ['MarkSash' => Ev('x'), Ev('y'), 1]);
+ $mw->bind($class, '<Button-2>' => ['MarkSash' => Ev('x'), Ev('y'), 0]);
+ $mw->bind($class, '<B1-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 1]);
+ $mw->bind($class, '<B2-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 0]);
+ $mw->bind($class, '<ButtonRelease-1>' => ['ReleaseSash' => 1]);
+ $mw->bind($class, '<ButtonRelease-2>' => ['ReleaseSash' => 0]);
+ $mw->bind($class, '<Motion>' => ['Motion' => Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Leave>' => ['Leave']);
+
+ return $class;
+
+} # end ClassInit
+
+sub MarkSash {
+
+ # MarkSash
+ #
+ # Handle marking the correct sash for possible dragging
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # proxy whether this should be a proxy sash
+ # Results:
+ # None
+
+ my ($w, $x, $y, $proxy) = @_;
+
+ my @what = $w->identify($x, $y);
+ if ( @what == 2 ) {
+ my ($index, $which) = @what[0 .. 1];
+ if (not $Tk::strictMotif or $which eq 'handle') {
+ $w->sashMark($index, $x, $y) if not $proxy;
+ $w->{_sash} = $index;
+ my ($sx, $sy) = $w->sashCoord($index);
+ $w->{_dx} = $sx - $x;
+ $w->{_dy} = $sy - $y;
+ }
+ }
+
+} # end MarkSash
+
+sub DragSash {
+
+ # DragSash
+ #
+ # Handle dragging of the correct sash
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # proxy whether this should be a proxy sash
+ # Results:
+ # Moves sash
+
+ my ($w, $x, $y, $proxy) = @_;
+
+ if ( exists $w->{_sash} ) {
+ if ($proxy) {
+ $w->proxyPlace($x + $w->{_dx}, $y + $w->{_dy});
+ } else {
+ $w->sashPlace($w->{_sash}, $x + $w->{_dx}, $y + $w->{_dy});
+ }
+ }
+
+} # end DragSash
+
+sub ReleaseSash {
+
+ # ReleaseSash
+ #
+ # Handle releasing of the sash
+ #
+ # Arguments:
+ # w the widget
+ # proxy whether this should be a proxy sash
+ # Results:
+ # Returns ...
+
+ my ($w, $proxy) = @_;
+
+ if ( exists $w->{_sash} ) {
+ if ($proxy) {
+ my ($x, $y) = $w->proxyCoord;
+ $w->sashPlace($w->{_sash}, $x, $y);
+ $w->proxyForget;
+ }
+ delete $w->{'_sash', '_dx', '_dy'};
+ }
+
+} # end ReleaseSash
+
+sub Motion {
+
+ # Motion
+ #
+ # Handle motion on the widget. This is used to change the cursor
+ # when the user moves over the sash area.
+ #
+ # Arguments:
+ # w the widget
+ # x widget local x coord
+ # y widget local y coord
+ # Results:
+ # May change the cursor. Sets up a timer to verify that we are still
+ # over the widget.
+
+ my ($w, $x, $y) = @_;
+
+ my @id = $w->identify($x, $y);
+ if ( (@id == 2) and
+ (not $Tk::strictMotif or $id[1] eq 'handle') ) {
+ if ( not exists $w->{_panecursor} ) {
+ $w->{_panecursor} = $w->cget(-cursor);
+ if ( not defined $w->cget(-sashcursor) ) {
+ if ( $w->cget(-orient) eq 'horizontal' ) {
+ $w->configure(-cursor => 'sb_h_double_arrow');
+ } else {
+ $w->configure(-cursor => 'sb_v_double_arrow');
+ }
+ } else {
+ $w->configure(-cursor => $w->cget(-sashcursor));
+ }
+ if ( exists $w->{_pwAfterId} ) {
+ $w->afterCancel($w->{_pwAfterId});
+ }
+ $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
+ }
+ return
+ }
+ if ( exists $w->{_panecursor} ) {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ }
+
+} # end Motion
+
+sub Cursor {
+
+ # Cursor
+ #
+ # Handles returning the normal cursor when we are no longer over the
+ # sash area. This needs to be done this way, because the panedwindow
+ # won't see Leave events when the mouse moves from the sash to a
+ # paned child, although the child does receive an Enter event.
+ #
+ # Arguments:
+ # w the widget
+ # Results:
+ # May restore the default cursor, or schedule a timer to do it.
+
+ my ($w) = @_;
+
+ if ( exists $w->{_panecursor} ) {
+ if ( $w->containing($w->pointerx, $w->pointery) == $w ) {
+ $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
+ } else {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ if ( exists $w->{_pwAfterId} ) {
+ $w->afterCancel($w->{_pwAfterId});
+ delete $w->{_pwAfterId};
+ }
+ }
+ }
+
+} # end Cursor
+
+sub Leave {
+
+ # Leave
+ #
+ # Return to default cursor when leaving the pw widget.
+ #
+ # Arguments:
+ # w the widget
+ # Results:
+ # Restores the default cursor
+
+ my ($w) = @_;
+
+ if ( exists $w->{_panecursor} ) {
+ $w->configure(-cursor => $w->{_panecursor});
+ delete $w->{_panecursor};
+ }
+
+} # end Leave
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Photo.pm b/Master/tlpkg/tlperl/lib/Tk/Photo.pm
new file mode 100644
index 00000000000..a596dc4d78b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Photo.pm
@@ -0,0 +1,22 @@
+package Tk::Photo;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Photo';
+
+sub Tk_image { 'photo' }
+
+Tk::Methods('blank','copy','data','formats','get','put','read',
+ 'redither','transparency','write');
+
+use Tk::Submethods (
+ 'transparency' => [qw/get set/],
+);
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm b/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm
new file mode 100644
index 00000000000..3fbc3179b56
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Pixmap.pm
@@ -0,0 +1,19 @@
+package Tk::Pixmap;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TixPixmap/Pixmap.pm#4 $
+
+use Tk qw($XS_VERSION);
+
+use Tk::Image ();
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Pixmap';
+
+bootstrap Tk::Pixmap;
+
+sub Tk_image { 'pixmap' }
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Pretty.pm b/Master/tlpkg/tlperl/lib/Tk/Pretty.pm
new file mode 100644
index 00000000000..7e442a4bcbc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Pretty.pm
@@ -0,0 +1,93 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Pretty;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(Pretty PrintArgs);
+
+sub pretty_list
+{
+ join(',',map(&Pretty($_),@_));
+}
+
+sub Pretty
+{
+ return pretty_list(@_) if (@_ > 1);
+ my $obj = shift;
+ return 'undef' unless defined($obj);
+ my $type = "$obj";
+ return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
+ my $result = '';
+ if (ref $obj)
+ {
+ my $class;
+ if ($type =~ /^([^=]+)=(.*)$/)
+ {
+ $class = $1;
+ $type = $2;
+ $result .= 'bless(';
+ }
+ if ($type =~ /^ARRAY/)
+ {
+ $result .= '[';
+ $result .= pretty_list(@$obj);
+ $result .= ']';
+ }
+ elsif ($type =~ /^HASH/)
+ {
+ $result .= '{';
+ if (%$obj)
+ {
+ my ($key, $value);
+ while (($key,$value) = each %$obj)
+ {
+ $result .= $key . '=>' . Pretty($value) . ',';
+ }
+ chop($result);
+ }
+ $result .= '}';
+ }
+ elsif ($type =~ /^REF/)
+ {
+ $result .= "\\" . Pretty($$obj);
+ }
+ elsif ($type =~ /^SCALAR/)
+ {
+ $result .= Pretty($$obj);
+ }
+ else
+ {
+ $result .= $type;
+ }
+ $result .= ",$class)" if (defined $class);
+ }
+ else
+ {
+ if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
+ $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
+ $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
+ )
+ {
+ $result .= $obj;
+ }
+ else
+ {
+ $result .= "'" . $obj . "'";
+ }
+ }
+ return $result;
+}
+
+sub PrintArgs
+{
+ my $name = (caller(1))[3];
+ print "$name(",Pretty(@_),")\n";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm b/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm
new file mode 100644
index 00000000000..206d843ea13
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ProgressBar.pm
@@ -0,0 +1,498 @@
+package Tk::ProgressBar;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk;
+use Tk::Canvas;
+use Tk::Trace;
+use Carp;
+use strict;
+
+use base qw(Tk::Derived Tk::Canvas);
+
+Construct Tk::Widget 'ProgressBar';
+
+sub ClassInit {
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class,'<Configure>', ['_layoutRequest',1]);
+}
+
+
+sub Populate {
+ my($c,$args) = @_;
+
+ $c->ConfigSpecs(
+ -width => [PASSIVE => undef, undef, 0],
+ '-length' => [PASSIVE => undef, undef, 0],
+ -from => [PASSIVE => undef, undef, 0],
+ -to => [PASSIVE => undef, undef, 100],
+ -blocks => [PASSIVE => undef, undef, 10],
+ -padx => [PASSIVE => 'padX', 'Pad', 0],
+ -pady => [PASSIVE => 'padY', 'Pad', 0],
+ -gap => [PASSIVE => undef, undef, 1],
+ -colors => [PASSIVE => undef, undef, undef],
+ -relief => [SELF => 'relief', 'Relief', 'sunken'],
+ -value => [METHOD => undef, undef, undef],
+ -variable => [METHOD => undef, undef, undef],
+ -anchor => [METHOD => 'anchor', 'Anchor', 'w'],
+ -resolution
+ => [PASSIVE => undef, undef, 1.0],
+ -highlightthickness
+ => [SELF => 'highlightThickness','HighlightThickness',0],
+ -troughcolor
+ => [PASSIVE => 'troughColor', 'Background', 'grey55'],
+ );
+ _layoutRequest($c,1);
+ $c->OnDestroy(['Destroyed' => $c]);
+}
+
+sub anchor {
+ my $c = shift;
+ my $var = \$c->{Configure}{'-anchor'};
+ my $old = $$var;
+
+ if(@_) {
+ my $new = shift;
+ croak "bad anchor position \"$new\": must be n, s, w or e"
+ unless $new =~ /^[news]$/;
+ $$var = $new;
+ }
+
+ $old;
+}
+
+sub _layoutRequest {
+ my $c = shift;
+ my $why = shift;
+ $c->afterIdle(['_arrange',$c]) unless $c->{'layout_pending'};
+ $c->{'layout_pending'} |= $why;
+}
+
+sub _arrange {
+ my $c = shift;
+ my $why = $c->{'layout_pending'};
+
+ $c->{'layout_pending'} = 0;
+
+ my $w = $c->Width;
+ my $h = $c->Height;
+ my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness');
+ my $x = abs(int($c->{Configure}{'-padx'})) + $bw;
+ my $y = abs(int($c->{Configure}{'-pady'})) + $bw;
+ my $value = $c->value;
+ my $from = $c->{Configure}{'-from'};
+ my $to = $c->{Configure}{'-to'};
+ my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0;
+ my $dir = $c->{Configure}{'-anchor'} =~ /[se]/i ? -1 : 1;
+
+ my($minv,$maxv) = $from < $to ? ($from,$to) : ($to,$from);
+
+ if($w == 1 && $h == 1) {
+ my $bw = $c->cget('-borderwidth');
+ my $defw = 10 + $y*2 + $bw *2;
+ my $defl = ($maxv - $minv) + $x*2 + $bw*2;
+
+ $h = $c->pixels($c->{Configure}{'-length'}) || $defl;
+ $w = $c->pixels($c->{Configure}{'-width'}) || $defw;
+
+ ($w,$h) = ($h,$w) if $horz;
+ $c->GeometryRequest($w,$h);
+ $c->parent->update;
+ $c->update;
+
+ $w = $c->Width;
+ $h = $c->Height;
+ }
+
+ $w -= $x*2;
+ $h -= $y*2;
+
+ my $length = $horz ? $w : $h;
+ my $width = $horz ? $h : $w;
+
+ my $blocks = int($c->{Configure}{'-blocks'});
+ my $gap = int($c->{Configure}{'-gap'});
+
+ $blocks = 1 if $blocks < 1;
+
+ my $gwidth = $gap * ( $blocks - 1);
+ my $bwidth = ($length - $gwidth) / $blocks;
+
+ if($bwidth < 3 || $blocks <= 1 || $gap <= 0) {
+ $blocks = 1;
+ $bwidth = $length;
+ $gap = 0;
+ }
+
+ if($why & 1) {
+ my $colors = $c->{Configure}{'-colors'} || [];
+ my $bdir = $from < $to ? $dir : 0 - $dir;
+
+ $c->delete($c->find('all'));
+
+ $c->createRectangle(0,0,$w+$x*2,$h+$y*2,
+ -fill => $c->{Configure}{'-troughcolor'},
+ -width => 0,
+ -outline => undef);
+
+ $c->{'cover'} = $c->createRectangle($x,$y,$w,$h,
+ -fill => $c->{Configure}{'-troughcolor'},
+ -width => 0,
+ -outline => undef);
+
+ my($x0,$y0,$x1,$y1);
+
+ if($horz) {
+ if($bdir > 0) {
+ ($x0,$y0) = ($x - $gap,$y);
+ }
+ else {
+ ($x0,$y0) = ($length + $x + $gap,$y);
+ }
+ ($x1,$y1) = ($x0,$y0 + $width);
+ }
+ else {
+ if($bdir > 0) {
+ ($x0,$y0) = ($x,$y - $gap);
+ }
+ else {
+ ($x0,$y0) = ($x,$length + $y + $gap);
+ }
+ ($x1,$y1) = ($x0 + $width,$y0);
+ }
+
+ my $blks = $blocks;
+ my $dval = ($maxv - $minv) / $blocks;
+ my $color = $c->cget('-foreground');
+ my $pos = 0;
+ my $val = $minv;
+
+ while($val < $maxv) {
+ my($bw,$nval);
+
+ while(($pos < @$colors) && $colors->[$pos] <= $val) {
+ $color = $colors->[$pos+1];
+ $pos += 2;
+ }
+
+ if($blocks == 1) {
+ $nval = defined($colors->[$pos])
+ ? $colors->[$pos] : $maxv;
+ $bw = (($nval - $val) / ($maxv - $minv)) * $length;
+ }
+ else {
+ $bw = $bwidth;
+ $nval = $val + $dval if($blocks > 1);
+ }
+
+ if($horz) {
+ if($bdir > 0) {
+ $x0 = $x1 + $gap;
+ $x1 = $x0 + $bw;
+ }
+ else {
+ $x1 = $x0 - $gap;
+ $x0 = $x1 - $bw;
+ }
+ }
+ else {
+ if($bdir > 0) {
+ $y0 = $y1 + $gap;
+ $y1 = $y0 + $bw;
+ }
+ else {
+ $y1 = $y0 - $gap;
+ $y0 = $y1 - $bw;
+ }
+ }
+
+ $c->createRectangle($x0,$y0,$x1,$y1,
+ -fill => $color,
+ -width => 0,
+ -outline => undef
+ );
+ $val = $nval;
+ }
+ }
+
+ my $cover = $c->{'cover'};
+ my $ddir = $from > $to ? 1 : -1;
+
+ if(($value <=> $to) == (0-$ddir)) {
+ $c->lower($cover);
+ }
+ elsif(($value <=> $from) == $ddir) {
+ $c->raise($cover);
+ my $x1 = $horz ? $x + $length : $x + $width;
+ my $y1 = $horz ? $y + $width : $y + $length;
+ $c->coords($cover,$x,$y,$x1,$y1);
+ }
+ else {
+ my $step;
+ $value = int($value / $step) * $step
+ if(defined($step = $c->{Configure}{'-resolution'}) && $step > 0);
+
+ $maxv = $minv+1
+ if $minv == $maxv;
+
+ my $range = $maxv - $minv;
+ my $bval = $range / $blocks;
+ my $offset = abs($value - $from);
+ my $ioff = int($offset / $bval);
+ my $start = $ioff * ($bwidth + $gap);
+ $start += ($offset - ($ioff * $bval)) / $bval * $bwidth;
+
+ my($x0,$x1,$y0,$y1);
+
+ if($horz) {
+ $y0 = $y;
+ $y1 = $y + $h;
+ if($dir > 0) {
+ $x0 = $x + $start;
+ $x1 = $x + $w;
+ }
+ else {
+ $x0 = $x;
+ $x1 = $w + $x - $start;
+ }
+ }
+ else {
+ $x0 = $x;
+ $x1 = $x + $w;
+ if($dir > 0) {
+ $y0 = $y + $start;
+ $y1 = $y + $h;
+ }
+ else {
+ $y0 = $y;
+ $y1 = $h + $y - $start;
+ }
+ }
+
+
+ $c->raise($cover);
+ $c->coords($cover,$x0,$y0,$x1,$y1);
+ }
+}
+
+sub value {
+ my $c = shift;
+ my $val = defined($c->{'-variable'})
+ ? $c->{'-variable'}
+ : \$c->{'-value'};
+ my $old = defined($$val) ? $$val : $c->{Configure}{'-from'};
+
+ if(@_) {
+ my $value = shift;
+ $$val = defined($value) ? $value : $c->{Configure}{'-from'};
+ _layoutRequest($c,2);
+ }
+
+ $old;
+}
+
+sub variable {
+ my $c = shift;
+ my $oldvarref = $c->{'-variable'};
+ my $oldval = $$oldvarref if $oldvarref;
+ if(@_) {
+ my $varref = shift;
+ if ($oldvarref)
+ {
+ $c->traceVdelete($oldvarref);
+ }
+ $c->{'-variable'} = $varref;
+ $c->traceVariable($varref, 'w', sub { $c->value($_[1]) });
+ $$varref = $oldval;
+ _layoutRequest($c,2);
+ }
+ $oldval;
+}
+
+sub Destroyed
+{
+ my $c = shift;
+ my $var = delete $c->{'-variable'};
+ $c->traceVdelete($var);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tk::ProgressBar - A graphical progress bar
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::ProgressBar;
+
+ $progress = $parent->ProgressBar(
+ -width => 200,
+ -length => 20,
+ -anchor => 's',
+ -from => 0,
+ -to => 100,
+ -blocks => 10,
+ -colors => [0, 'green', 50, 'yellow' , 80, 'red'],
+ -variable => \$percent_done
+ );
+
+ $progress->value($position);
+
+=head1 DESCRIPTION
+
+B<Tk::ProgressBar> provides a widget which will show a graphical representation
+of a value, given maximum and minimum reference values.
+
+=head1 STANDARD OPTIONS
+
+The following standard widget options are supported:
+
+=over 4
+
+=item B<-borderwidth>
+
+=item B<-highlightthickness>
+
+Defaults to 0.
+
+=item B<-padx>
+
+Defaults to 0.
+
+=item B<-pady>
+
+Defaults to 0.
+
+=item B<-relief>
+
+Defaults to C<sunken>
+
+=item B<-troughcolor>
+
+The color to be used for the background (trough) of the progress bar.
+Default is to use grey55.
+
+=back
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=over 4
+
+=item B<-anchor>
+
+This can be used to position the start point of the bar. Default
+is 'w' (horizontal bar starting from the left). A vertical bar can be
+configured by using either 's' or 'n'.
+
+=item B<-blocks>
+
+This controls the number of blocks to be used to construct the progress
+bar. The default is to break the bar into 10 blocks.
+
+=item B<-colors>
+
+Controls the colors to be used for different positions of the progress bar.
+The colors should be supplied as a reference to an array containing pairs
+of positions and colors.
+
+ -colors => [ 0, 'green', 50, 'red' ]
+
+means that for the range 0 to 50 the progress bar should be green
+and for higher values it should be red.
+
+
+=item B<-from>
+
+This sets the lower limit of the progress bar. If the bar is set to a
+value below the lower limt no bar will be displayed. Defaults to 0.
+See the C<-to> description for more information.
+
+=item B<-gap>
+
+This is the spacing (in pixels) between each block. Defaults to 1.
+Use 0 to get a continuous bar.
+
+
+=item B<-length>
+
+Specifies the desired long dimension of the ProgressBar in screen
+units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical
+ProgressBars this is the ProgressBars height; for horizontal scales it
+is the ProgressBars width. The default length is calculated from the
+values of C<-padx>, C<-borderwidth>, C<-highlightthickness> and the
+difference between C<-from> and C<-to>.
+
+
+=item B<-resolution>
+
+A real value specifying the resolution for the scale. If this value is greater
+than zero then the scale's value will always be rounded to an even multiple of
+this value, as will tick marks and the endpoints of the scale. If the value is
+less than zero then no rounding occurs. Defaults to 1 (i.e., the value will be
+integral).
+
+=item B<-to>
+
+This sets the upper limit of the progress bar. If a value is specified
+(for example, using the C<value> method) that lies above this value the
+full progress bar will be displayed. Defaults to 100.
+
+
+
+=item B<-variable>
+
+Specifies the reference to a scalar variable to link to the ProgressBar.
+Whenever the value of the variable changes, the ProgressBar will upate
+to reflect this value. (See also the B<value> method below.)
+
+=item B<-value>
+
+The can be used to set the current position of the progress bar
+when used in conjunction with the standard C<configure>. It is
+usually recommended to use the B<value> method instead.
+
+
+=item B<-width>
+
+Specifies the desired narrow dimension of the ProgressBar in screen
+units (i.e. any of the forms acceptable to Tk_GetPixels). For
+vertical ProgressBars this is the ProgressBars width; for horizontal
+bars this is the ProgressBars height. The default width is derived
+from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>.
+
+=back
+
+=head1 WIDGET METHODS
+
+=over 4
+
+=item I<$ProgressBar>-E<gt>B<value>(?I<value>?)
+
+If I<value> is omitted, returns the current value of the ProgressBar. If
+I<value> is given, the value of the ProgressBar is set. If I<$value> is
+given but undefined the value of the option B<-from> is used.
+
+=back
+
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/README.Adjust b/Master/tlpkg/tlperl/lib/Tk/README.Adjust
new file mode 100644
index 00000000000..8c3eba45717
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/README.Adjust
@@ -0,0 +1,77 @@
+Subject: Adjuster
+Date: Wed, 16 Dec 1998 22:23:23 +0100
+From: Stephen Kun <stephen.kun@is.gaertner.de>
+To: Nick Ing-Simmons <nick@ni-s.u-net.com>
+
+
+
+
+3. How do I find out whether slave is a pack or grid master or if it is not a
+master (for setting packPropagate(0))
+Currently I set both on the slave.
+
+4. In setting position of drag bar, I do a lot of calcs for each motion event.
+Some could be done one for first, then used again for subsequent calls, eg:
+borderwidth of master, etc.
+I've now partially done this and store them on the widget.
+
+5. Do I need XSync and idletasks calls in Adjuster.pm?
+XSync causes a bug. idletasks doesn't make any difference in practice, from
+what I can see. I've commented both out.
+Bug when using XSync:
+ Run pack_adj_4r
+ Shorten whole window from right so that left window edge crosses leftmost
+ adjuster. Buttons on other adjusters disappear
+
+6. Sometimes the effect given by the Restore method, is undesirable. Eg.
+for multi-columns. Then when you expand say the 1st column, the size of the
+col at the end gets reduced to 0 width when the Adjuster forces itself in.
+Then when you reduce the size of the first column again, the end col is still
+0 width.
+Better would be:
+a) put the restore functionality on a flag OR
+b) when a col is reduced because of a Restore, it saves previous width of
+its slave, and attempts to restore it when the space becomes availabe. (Sounds
+impracticable.)
+I've implemented a) with default ON. In the documentation I'll recommend the
+default for the 1st Adjuster, then OFF for the remaining.
+
+8. What about a packAdjustForget? Given that Adjuster doesn't work well for
+grid anyway, and doesn't consider other managers, that wouldn't be too bad.
+I'm not going to do this, but someone mentioned it a while ago. I can
+see me probably wanting it too at some point.
+Are you for the idea?
+
+10. Grid doesn't work well with Adjuster, didn't before either. I think
+this has to do with grid, rather than adjuster. You get the same effect
+if you grid a row of widgets, then reduce the width of the window.
+Bugs demonstrated by grid_adj_4l:
+a) there's never an Unmap event for the adjuster.
+b) after adjusting, widgets protrude into border on right.
+c) grid('Propagate', 0) on MainWindow has no effect - window shrinks/grows
+ when widgets are adjusted
+d) widgets shuffle to correct position on startup
+I don't recommend use of grid with Adjust!
+
+11. Have taken out __END__ temporarily for testing
+Will put it back before publishing on the mailing list.
+
+12. Why do the adjusters in my testcases come out grey? That's not the
+default background.
+
+13. Could packAdjust return ($adj, $w). Could then do:
+ my $canv = $top->Canvas()->packAdjust();
+OR
+ my ($adj, $canv) = $top->Canvas()->packAdjust();
+Latter is good if you want to configure or unpack adjuster later.
+I realise this is very Kludgy, but there's no other way to get the
+Adjuster from packAdjust.
+I suppose the workaround of creating the Adjuster yourself is OK. When
+you do it by hand though, there's more chance of making mistakes, eg
+forgetting the -side (which defaults then to 'top') which would cause havoc.
+What's your opinion.
+
+14. Run the script adj_button_bug: You can't reduce size of button.
+Button can be expanded, but as soon as focus enters button, it springs back
+to its original size. Why?
+It's not important though.
diff --git a/Master/tlpkg/tlperl/lib/Tk/ROText.pm b/Master/tlpkg/tlperl/lib/Tk/ROText.pm
new file mode 100644
index 00000000000..cc5634f5475
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ROText.pm
@@ -0,0 +1,43 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::ROText;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Text;
+use base qw(Tk::Derived Tk::Text);
+
+Construct Tk::Widget 'ROText';
+
+sub clipEvents
+{
+ return qw[Copy];
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ my $val = $class->bindRdOnly($mw);
+ my $cb = $mw->bind($class,'<Next>');
+ $mw->bind($class,'<space>',$cb) if (defined $cb);
+ $cb = $mw->bind($class,'<Prior>');
+ $mw->bind($class,'<BackSpace>',$cb) if (defined $cb);
+ $class->clipboardOperations($mw,'Copy');
+ return $val;
+}
+
+sub Populate {
+ my($self,$args) = @_;
+ $self->SUPER::Populate($args);
+ my $m = $self->menu->entrycget($self->menu->index('Search'), '-menu');
+ $m->delete($m->index('Replace'));
+}
+
+sub Tk::Widget::ScrlROText { shift->Scrolled('ROText' => @_) }
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm b/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm
new file mode 100644
index 00000000000..d09d41b4208
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Radiobutton.pm
@@ -0,0 +1,45 @@
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+package Tk::Radiobutton;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Button;
+
+
+use base qw(Tk::Button);
+Construct Tk::Widget 'Radiobutton';
+
+sub Tk_cmd { \&Tk::radiobutton }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-variable');
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Region.pm b/Master/tlpkg/tlperl/lib/Tk/Region.pm
new file mode 100644
index 00000000000..3e02bd2ff49
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Region.pm
@@ -0,0 +1,182 @@
+package Tk::Region;
+
+# Ideas in progress do not document ...
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $
+
+use Tk::Widget ();
+
+Construct Tk::Widget 'Region';
+
+my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5);
+
+sub _attr
+{
+ my ($obj,$key,$val) = @_;
+ if (@_ > 2)
+ {
+ $obj->{$key} = $val;
+ }
+ return $obj->{$key}
+}
+
+foreach my $name (qw(widget x y width height))
+ {
+ my $key = "-$name";
+ no strict 'refs';
+ *{$name} = sub { shift->_attr($key,@_) };
+ }
+
+sub new
+{
+ my $class = shift;
+ my $widget = shift;
+ my $obj = bless [\%index,$widget,0,0,0,0],$class;
+ $obj->configure(@_);
+}
+
+sub cfgDefault
+{
+ my ($class,$key) = @_;
+ return undef;
+}
+
+sub cfgName
+{
+ my ($class,$key) = @_;
+ $key =~ s/^-//;
+ return lcfirst($key);
+}
+
+sub cfgClass
+{
+ return ucfirst(shift->cfgName(@_));
+}
+
+sub configure
+{
+ my $obj = shift;
+ my @results;
+ if (@_ > 1)
+ {
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ if (exists $obj->{$key})
+ {
+ $obj->{$key} = $val;
+ }
+ else
+ {
+ my ($meth) = $key =~ /^-(\w+)$/;
+ croak("Invalid option $key") unless $obj->can($meth);
+ $obj->$meth($val);
+ }
+ }
+ }
+ elsif (@_ == 1)
+ {
+ my $key = shift;
+ my $value = $obj->cget($key);
+ push(@results,$key,$obj->cfgName($key),$obj->cfgClass($key),$obj->cfgDefault($key),$value);
+ }
+ else
+ {
+ foreach my $key (sort keys %$obj)
+ {
+ push(@results,scalar($obj->configure($key)))
+ }
+ }
+ return wantarray ? @results : \@results;
+}
+
+sub cget
+{
+ my $obj = shift;
+ my $key = shift;
+ return $obj->{$key} if exists $obj->{$key};
+ my ($meth) = $key =~ /^-(\w+)$/;
+ croak("Invalid option $key") unless $obj->can($meth);
+ return $obj->$meth();
+}
+
+sub bbox
+{
+ my $obj = shift;
+ my @results;
+ if (@_)
+ {
+ my $ref = (@_ == 1) ? shift : \@_;
+ my ($x1,$y1,$x2,$y2) = (ref $ref) ? @$ref : split(/\s+/,$ref);
+ ($x2,$x1) = ($x1,$x2) if ($x2 < $x1);
+ ($y2,$y1) = ($y1,$y2) if ($y2 < $y1);
+ $obj->width($x2-$x1);
+ $obj->height($y2-$y1);
+ $obj->x($x1);
+ $obj->y($y1);
+ }
+ else
+ {
+ my $x = $obj->x;
+ my $y = $obj->x;
+ push(@results,$x,$y,$x+$obj->width,$y+$obj->height);
+ }
+ return wantarray ? @results : \@results;
+}
+
+sub rootx
+{
+ my $obj = shift;
+ if (@_)
+ {
+ my $x = shift;
+ $obj->x($x-$obj->widget->rootx);
+ }
+ return $obj->widget->rootx + $obj->{'-x'}
+}
+
+sub rooty
+{
+ my $obj = shift;
+ if (@_)
+ {
+ my $y = shift;
+ $obj->y($y-$obj->widget->rootx);
+ }
+ return $obj->widget->rooty + $obj->{'-y'}
+}
+
+sub rootxy
+{
+ my $obj = shift;
+ if (@_)
+ {
+ $obj->rootx(shift);
+ $obj->rooty(shift);
+ }
+ my @results = ($obj->rootx,$obj->rooty);
+ return wantarray ? @results : \@results;
+}
+
+sub rootbbox
+{
+ my $obj = shift;
+ my ($x1,$y1) = $obj->rootxy;
+ my $x2 = $x1+$obj->width;
+ my $y2 = $y1+$obj->height;
+ my @results = ($x1,$y1,$x2,$y2);
+ return wantarray ? @results : \@results;
+}
+
+
+*Width = \&width;
+*Height = \&height;
+*X = \&rootx;
+*Y = \&rooty;
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Reindex.pm b/Master/tlpkg/tlperl/lib/Tk/Reindex.pm
new file mode 100644
index 00000000000..05e8e1fc1fc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Reindex.pm
@@ -0,0 +1,225 @@
+package Tk::Reindex;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/Reindex.pm#4 $
+
+use Tk;
+use base qw(Tk::Derived);
+
+
+sub Populate
+{
+ my ($w, $args) = @_;
+
+ $w->_callbase('Populate',$args);
+
+ $w->ConfigSpecs(-linestart => ["PASSIVE", "lineStart", "LineStart", 0],
+ -toindexcmd => ["CALLBACK", "toIndexCmd", "ToIndexCmd" , [\&to_index,$w]],
+ -fromindexcmd => ["CALLBACK", "fromIndexCmd","FromIndexCmd", [\&from_index,$w]]);
+}
+
+sub import
+{
+ my($module,$base)=@_;
+ my $pkg=(caller)[0];
+
+ no strict 'refs';
+ *{"${pkg}::_reindexbase"}=sub{$base};
+}
+
+sub _callbase
+{
+ my($w,$sub)=(shift,shift);
+ my $supersub=$w->_reindexbase()."::$sub";
+ $w->$supersub(@_);
+}
+
+BEGIN
+{
+ # list of subroutines and index argument number (-1 as first element means return value)
+ my %subs=('bbox' => [0],
+ 'compare' => [0,2],
+ 'delete' => [0,1],
+ 'dlineinfo' => [0],
+ 'dump' => \&_find_dump_index,
+ 'get' => [0,1],
+ 'index' => [-1,0],
+ 'insert' => [0],
+ 'mark' => \&_find_mark_index,
+ 'search' => \&_find_search_index,
+ 'see' => [0],
+ 'tag' => \&_find_tag_index,
+ 'window' => [1],
+ 'image' => [1],
+ );
+
+ foreach my $sub (keys %subs)
+ {
+ my $args=$subs{$sub};
+ my $argsub=ref $args eq 'CODE'?$args:sub{$args};
+ my $newsub=sub
+ {
+ my($w)=shift;
+ my(@iargs)=grep($_<=$#_,@{$argsub->(@_)});
+ my $iret=shift @iargs if @iargs && $iargs[0]==-1;
+ my(@args)=@_;
+ @args[@iargs]=$w->Callback(-toindexcmd,@args[@iargs]);
+ my(@ret)=$w->_callbase($sub,@args);
+ @ret=$w->Callback(-fromindexcmd,@ret) if $iret;
+ wantarray?@ret:$ret[0];
+ };
+ no strict 'refs';
+ *{$sub}=$newsub;
+ }
+}
+
+sub to_index
+{
+ my $w=shift;
+ my $offset=$w->cget(-linestart)+1;
+ my(@args)=@_;
+ foreach (@args)
+ {
+ s/^\d+(?=\.)/$&+$offset/e;
+ }
+ @args;
+}
+
+sub from_index
+{
+ my $w=shift;
+ my $offset=$w->cget(-linestart)+1;
+ my(@args)=@_;
+ foreach (@args)
+ {
+ s/^\d+(?=\.)/$&-$offset/e
+ }
+ @args;
+}
+
+sub _find_dump_index
+{
+ my $idx=_count_options(@_);
+ [$idx,$idx+1];
+}
+
+sub _find_search_index
+{
+ my $idx=_count_options(@_);
+ [$idx+1,$idx+2];
+}
+
+sub _count_options
+{
+ my $idx=0;
+ while($_[$idx]=~/^-/g)
+ {
+ $idx++;
+ $idx++ if $' eq 'count' or $' eq 'command';
+ last if $' eq '-';
+ }
+ $idx;
+}
+
+sub _find_tag_index
+{
+ return [1] if $_[0] eq 'names';
+ return [2,3] if $_[0]=~/^(add|remove|nextrange|prevrange)$/;
+ return [-1] if $_[0] eq 'ranges';
+ return [];
+}
+
+sub _find_mark_index
+{
+ return [2] if $_[0] eq 'set';
+ return [1] if $_[0] eq 'next' or $_[0] eq 'previous';
+ return [];
+}
+
+1;
+
+=head1 NAME
+
+Tk::Reindex - change the base index of Text-like widgets
+
+=for category Derived Widgets
+
+=head1 SYNOPSIS
+
+ use Tk::ReindexedText;
+ $t1=$w->ReindexedText(-linestart => 2);
+
+ use Tk::ReindexedROText;
+ $t2=$w->ReindexedROText(-linestart => 0);
+
+=head1 DESCRIPTION
+
+Creates a new widget class based on B<Text>-like widgets that can
+redefine the line number base (normally B<Text> widgets start line
+numbers at 1), or possibly other manipulations on indexes.
+
+=head1 STANDARD OPTIONS
+
+The newly-defined widget takes all the same options as the base
+widget, which defaults to B<Text>.
+
+=head1 WIDGET-SPECIFIC OPTIONS
+
+=item Name: B<lineStart>
+
+=item Class: B<LineStart>
+
+=item Switch: B<-linestart>
+
+Sets the line number of the first line in the B<Text> widget. The
+default B<-toindexcmd> and B<-fromindexcmd> use this configuration
+option.
+
+-item Name: B<toIndexCmd> B<fromIndexCmd>
+
+-item Class: B<ToIndexCmd> B<FromIndexCmd>
+
+-item Switch: B<-toindexcmd> B<-fromindexcmd>
+
+These two options specify callbacks that are called with a list of
+indexes and are responsible for translating them to/from indexes that
+the base B<Text> widget can understand. The callback is passed the
+widget followed by a list of indexes, and should return a list of
+translated indexes. B<-toindexcmd> should translate from 'user'
+indexes to 'native' B<Text>-compatible indexes, and B<-fromindexcmd>
+should translate from 'native' indexes to 'user' indexes.
+
+The default callbacks simply add/subtract the offset given by the
+B<-linestart> option for all indexes in 'line.character' format.
+
+It would probably be prudent to make these functions inverses of each
+other.
+
+=head1 CLASS METHODS
+
+=item import
+
+To make new Reindex widgets, this function should be called via B<use>
+with the name of the Text-like base class that you are extending with
+"Reindex" capability. 'use base(Tk::Reindex Tk::nameofbasewidget)'
+should also be specified for that widget.
+
+=head1 BUGS
+
+I've used the word "indexes" instead of "indices" throughout the
+documentation.
+
+All the built-in perl code for widget bindings & methods will use the
+new 'user' indexes. Which means all this index manipulation might
+might break code that is trying to parse/manipulate indexes. Or even
+assume that '1.0' is the beginning index. B<Tk::Text::Contents> comes
+to mind.
+
+=head1 AUTHOR
+
+Andrew Allen <ada@fc.hp.com>
+
+This code may be distributed under the same conditions as Perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm b/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm
new file mode 100644
index 00000000000..8c293f5fa61
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ReindexedROText.pm
@@ -0,0 +1,13 @@
+use strict;
+package Tk::ReindexedROText;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedROText.pm#4 $
+
+use Tk::Reindex qw(Tk::ROText);
+use base qw(Tk::Reindex Tk::ROText);
+Construct Tk::Widget 'ReindexedROText';
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm b/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm
new file mode 100644
index 00000000000..c16a6fe7fd7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/ReindexedText.pm
@@ -0,0 +1,13 @@
+use strict;
+package Tk::ReindexedText;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/TextList/ReindexedText.pm#4 $
+
+use Tk::Reindex qw(Tk::Text);
+use base qw(Tk::Reindex Tk::Text);
+Construct Tk::Widget 'ReindexedText';
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Scale.pm b/Master/tlpkg/tlperl/lib/Tk/Scale.pm
new file mode 100644
index 00000000000..57c7bb11aa1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Scale.pm
@@ -0,0 +1,278 @@
+# Converted from scale.tcl --
+#
+# This file defines the default bindings for Tk scale widgets.
+#
+# @(#) scale.tcl 1.3 94/12/17 16:05:23
+#
+# Copyright (c) 1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package Tk::Scale;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Scale/Scale.pm#4 $
+
+use Tk qw($XS_VERSION);
+use AutoLoader;
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Scale';
+
+bootstrap Tk::Scale;
+
+sub Tk_cmd { \&Tk::scale }
+
+Tk::Methods('coords','get','identify','set');
+
+
+import Tk qw(Ev);
+
+#
+# Bind --
+# This procedure below invoked the first time the mouse enters a
+# scale widget or a scale widget receives the input focus. It creates
+# all of the class bindings for scales.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<Enter>',['Enter',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Motion>',['Activate',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<Leave>','Leave');
+
+ $mw->bind($class,'<1>',['ButtonDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>',['Drag',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Leave>','NoOp');
+ $mw->bind($class,'<B1-Enter>','NoOp');
+ $mw->bind($class,'<ButtonRelease-1>',['ButtonUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<2>',['ButtonDown',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['Drag',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Leave>','NoOp');
+ $mw->bind($class,'<B2-Enter>','NoOp');
+ $mw->bind($class,'<ButtonRelease-2>',['ButtonUp',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Control-1>',['ControlPress',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Up>',['Increment','up','little','noRepeat']);
+ $mw->bind($class,'<Down>',['Increment','down','little','noRepeat']);
+ $mw->bind($class,'<Left>',['Increment','up','little','noRepeat']);
+ $mw->bind($class,'<Right>',['Increment','down','little','noRepeat']);
+
+ $mw->bind($class,'<Control-Up>',['Increment','up','big','noRepeat']);
+ $mw->bind($class,'<Control-Down>',['Increment','down','big','noRepeat']);
+ $mw->bind($class,'<Control-Left>',['Increment','up','big','noRepeat']);
+ $mw->bind($class,'<Control-Right>',['Increment','down','big','noRepeat']);
+
+ $mw->bind($class,'<Home>',['set',Ev('cget','-from')]);
+ $mw->bind($class,'<End>',['set',Ev('cget','-to')]);
+ return $class;
+}
+
+1;
+
+__END__
+
+# Activate --
+# This procedure is invoked to check a given x-y position in the
+# scale and activate the slider if the x-y position falls within
+# the slider.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Activate
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ return if ($w->cget('-state') eq 'disabled');
+ my $ident = $w->identify($x,$y);
+ if (defined($ident) && $ident eq 'slider')
+ {
+ $w->configure(-state => 'active')
+ }
+ else
+ {
+ $w->configure(-state => 'normal')
+ }
+}
+
+sub Leave
+{
+ my ($w) = @_;
+ $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif);
+ $w->configure('-state','normal') if ($w->cget('-state') eq 'active');
+}
+
+sub Enter
+{
+ my ($w,$x,$y) = @_;
+ if ($Tk::strictMotif)
+ {
+ $w->{'activeBg'} = $w->cget('-activebackground');
+ $w->configure('-activebackground',$w->cget('-background'));
+ }
+ $w->Activate($x,$y);
+}
+
+sub ButtonUp
+{
+ my ($w,$x,$y) = @_;
+ $w->CancelRepeat();
+ $w->EndDrag();
+ $w->Activate($x,$y)
+}
+
+
+# ButtonDown --
+# This procedure is invoked when a button is pressed in a scale. It
+# takes different actions depending on where the button was pressed.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates of button press.
+sub ButtonDown
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ $Tk::dragging = 0;
+ $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->Increment('up','little','initial')
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->Increment('down','little','initial')
+ }
+ elsif ($el eq 'slider')
+ {
+ $Tk::dragging = 1;
+ my @coords = $w->coords();
+ $Tk::deltaX = $x-$coords[0];
+ $Tk::deltaY = $y-$coords[1];
+ }
+}
+# Drag --
+# This procedure is called when the mouse is dragged with
+# mouse button 1 down. If the drag started inside the slider
+# (i.e. the scale is active) then the scale's value is adjusted
+# to reflect the mouse's position.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates.
+sub Drag
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY))
+}
+# EndDrag --
+# This procedure is called to end an interactive drag of the
+# slider. It just marks the drag as over.
+# Arguments:
+# w - The scale widget.
+sub EndDrag
+{
+ my $w = shift;
+ if (!$Tk::dragging)
+ {
+ return;
+ }
+ $Tk::dragging = 0;
+}
+# Increment --
+# This procedure is invoked to increment the value of a scale and
+# to set up auto-repeating of the action if that is desired. The
+# way the value is incremented depends on the "dir" and "big"
+# arguments.
+#
+# Arguments:
+# w - The scale widget.
+# dir - "up" means move value towards -from, "down" means
+# move towards -to.
+# big - Size of increments: "big" or "little".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+sub Increment
+{
+ my $w = shift;
+ my $dir = shift;
+ my $big = shift;
+ my $repeat = shift;
+ my $inc;
+ if ($big eq 'big')
+ {
+ $inc = $w->cget('-bigincrement');
+ if ($inc == 0)
+ {
+ $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0
+ }
+ if ($inc < $w->cget('-resolution'))
+ {
+ $inc = $w->cget('-resolution')
+ }
+ }
+ else
+ {
+ $inc = $w->cget('-resolution')
+ }
+ if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up'))
+ {
+ $inc = -$inc
+ }
+ $w->set($w->get()+$inc);
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again'));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again'));
+ }
+}
+# ControlPress --
+# This procedure handles button presses that are made with the Control
+# key down. Depending on the mouse position, it adjusts the scale
+# value to one end of the range or the other.
+#
+# Arguments:
+# w - The scale widget.
+# x, y - Mouse coordinates where the button was pressed.
+sub ControlPress
+{
+ my ($w,$x,$y) = @_;
+ my $el = $w->identify($x,$y);
+ return unless ($el);
+ if ($el eq 'trough1')
+ {
+ $w->set($w->cget('-from'))
+ }
+ elsif ($el eq 'trough2')
+ {
+ $w->set($w->cget('-to'))
+ }
+}
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm b/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm
new file mode 100644
index 00000000000..6b416e04b30
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm
@@ -0,0 +1,429 @@
+# Conversion from Tk4.0 scrollbar.tcl competed.
+package Tk::Scrollbar;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $
+
+use Tk qw($XS_VERSION Ev);
+use AutoLoader;
+
+use base qw(Tk::Widget);
+
+#use strict;
+#use vars qw($pressX $pressY @initValues $initPos $activeBg);
+
+Construct Tk::Widget 'Scrollbar';
+
+bootstrap Tk::Scrollbar;
+
+sub Tk_cmd { \&Tk::scrollbar }
+
+Tk::Methods('activate','delta','fraction','get','identify','set');
+
+sub Needed
+{
+ my ($sb) = @_;
+ my @val = $sb->get;
+ return 1 unless (@val == 2);
+ return 1 if $val[0] != 0.0;
+ return 1 if $val[1] != 1.0;
+ return 0;
+}
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class, '<Enter>', 'Enter');
+ $mw->bind($class, '<Motion>', 'Motion');
+ $mw->bind($class, '<Leave>', 'Leave');
+
+ $mw->bind($class, '<1>', 'ButtonDown');
+ $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp');
+ $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave>
+ $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter>
+ $mw->bind($class, '<Control-1>', 'ScrlTopBottom');
+
+ $mw->bind($class, '<2>', 'ButtonDown');
+ $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp');
+ $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave>
+ $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter>
+ $mw->bind($class, '<Control-2>', 'ScrlTopBottom');
+
+ $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]);
+ $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]);
+ $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]);
+ $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]);
+
+ $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]);
+ $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]);
+ $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]);
+ $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]);
+
+ $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]);
+ $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]);
+
+ # X11 mousewheel - honour for horizontal too.
+ $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]);
+ $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]);
+
+ $mw->bind($class, '<Home>', ['ScrlToPos', 0]);
+ $mw->bind($class, '<End>', ['ScrlToPos', 1]);
+
+ $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]);
+ $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]);
+
+ return $class;
+
+}
+
+1;
+
+__END__
+
+sub Enter
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ if ($Tk::strictMotif)
+ {
+ my $bg = $w->cget('-background');
+ $activeBg = $w->cget('-activebackground');
+ $w->configure('-activebackground' => $bg);
+ }
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+sub Leave
+{
+ my $w = shift;
+ if ($Tk::strictMotif)
+ {
+ $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
+ }
+ $w->activate('');
+}
+
+sub Motion
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# tkScrollButtonDown --
+# This procedure is invoked when a button is pressed in a scrollbar.
+# It changes the way the scrollbar is displayed and takes actions
+# depending on where the mouse is.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonDown
+{my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ $w->configure('-activerelief' => 'sunken');
+ if ($e->b == 1 and
+ (defined($element) && $element eq 'slider'))
+ {
+ $w->StartDrag($e->x,$e->y);
+ }
+ elsif ($e->b == 2 and
+ (defined($element) && $element =~ /^(trough[12]|slider)$/o))
+ {
+ my $pos = $w->fraction($e->x, $e->y);
+ my($head, $tail) = $w->get;
+ my $len = $tail - $head;
+
+ $head = $pos - $len/2;
+ $tail = $pos + $len/2;
+ if ($head < 0) {
+ $head = 0;
+ $tail = $len;
+ }
+ elsif ($tail > 1) {
+ $head = 1 - $len;
+ $tail = 1;
+ }
+ $w->ScrlToPos($head);
+ $w->set($head, $tail);
+
+ $w->StartDrag($e->x,$e->y);
+ }
+ else
+ {
+ $w->Select($element,'initial');
+ }
+}
+
+# tkScrollButtonUp --
+# This procedure is invoked when a button is released in a scrollbar.
+# It cancels scans and auto-repeats that were in progress, and restores
+# the way the active element is displayed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates.
+
+sub ButtonUp
+{my $w = shift;
+ my $e = $w->XEvent;
+ $w->CancelRepeat;
+ $w->configure('-activerelief' => 'raised');
+ $w->EndDrag($e->x,$e->y);
+ $w->activate($w->identify($e->x,$e->y));
+}
+
+# tkScrollSelect --
+# This procedure is invoked when button 1 is pressed over the scrollbar.
+# It invokes one of several scrolling actions depending on where in
+# the scrollbar the button was pressed.
+#
+# Arguments:
+# w - The scrollbar widget.
+# element - The element of the scrollbar that was selected, such
+# as "arrow1" or "trough2". Shouldn't be "slider".
+# repeat - Whether and how to auto-repeat the action: "noRepeat"
+# means don't auto-repeat, "initial" means this is the
+# first action in an auto-repeat sequence, and "again"
+# means this is the second repetition or later.
+
+sub Select
+{
+ my $w = shift;
+ my $element = shift;
+ my $repeat = shift;
+ return unless defined ($element);
+ if ($element eq 'arrow1')
+ {
+ $w->ScrlByUnits('hv',-1);
+ }
+ elsif ($element eq 'trough1')
+ {
+ $w->ScrlByPages('hv',-1);
+ }
+ elsif ($element eq 'trough2')
+ {
+ $w->ScrlByPages('hv', 1);
+ }
+ elsif ($element eq 'arrow2')
+ {
+ $w->ScrlByUnits('hv', 1);
+ }
+ else
+ {
+ return;
+ }
+
+ if ($repeat eq 'again')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
+ }
+ elsif ($repeat eq 'initial')
+ {
+ $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
+ }
+}
+
+# tkScrollStartDrag --
+# This procedure is called to initiate a drag of the slider. It just
+# remembers the starting position of the slider.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the start of the drag operation.
+
+sub StartDrag
+{
+ my($w,$x,$y) = @_;
+ return unless (defined ($w->cget('-command')));
+ $pressX = $x;
+ $pressY = $y;
+ @initValues = $w->get;
+ my $iv0 = $initValues[0];
+ if (@initValues == 2)
+ {
+ $initPos = $iv0;
+ }
+ elsif ($iv0 == 0)
+ {
+ $initPos = 0;
+ }
+ else
+ {
+ $initPos = $initValues[2]/$initValues[0];
+ }
+}
+
+# tkScrollDrag --
+# This procedure is called for each mouse motion even when the slider
+# is being dragged. It notifies the associated widget if we're not
+# jump scrolling, and it just updates the scrollbar if we are jump
+# scrolling.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The current mouse position.
+
+sub Drag
+{
+ my($w,$x,$y) = @_;
+ return if !defined $initPos;
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ if ($w->cget('-jump'))
+ {
+ if (@initValues == 2)
+ {
+ $w->set($initValues[0]+$delta, $initValues[1]+$delta);
+ }
+ else
+ {
+ $delta = sprintf "%d", $delta * $initValues[0]; # round()
+ $initValues[2] += $delta;
+ $initValues[3] += $delta;
+ $w->set(@initValues[2,3]);
+ }
+ }
+ else
+ {
+ $w->ScrlToPos($initPos+$delta);
+ }
+}
+
+# tkScrollEndDrag --
+# This procedure is called to end an interactive drag of the slider.
+# It scrolls the window if we're in jump mode, otherwise it does nothing.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - The mouse position at the end of the drag operation.
+
+sub EndDrag
+{
+ my($w,$x,$y) = @_;
+ return if (!defined $initPos);
+ if ($w->cget('-jump'))
+ {
+ my $delta = $w->delta($x-$pressX, $y-$pressY);
+ $w->ScrlToPos($initPos+$delta);
+ }
+ undef $initPos;
+}
+
+# tkScrlByUnits --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of units. It notifies the associated widget
+# in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many units to scroll: typically 1 or -1.
+
+sub ScrlByUnits
+{my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'units');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount);
+ }
+}
+
+# tkScrlByPages --
+# This procedure tells the scrollbar's associated widget to scroll up
+# or down by a given number of screenfuls. It notifies the associated
+# widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# orient - Which kinds of scrollbars this applies to: "h" for
+# horizontal, "v" for vertical, "hv" for both.
+# amount - How many screens to scroll: typically 1 or -1.
+
+sub ScrlByPages
+{
+ my $w = shift;
+ my $orient = shift;
+ my $amount = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('scroll',$amount,'pages');
+ }
+ else
+ {
+ $cmd->Call($info[2]+$amount*($info[1]-1));
+ }
+}
+
+# tkScrlToPos --
+# This procedure tells the scrollbar's associated widget to scroll to
+# a particular location, given by a fraction between 0 and 1. It notifies
+# the associated widget in different ways for old and new command syntaxes.
+#
+# Arguments:
+# w - The scrollbar widget.
+# pos - A fraction between 0 and 1 indicating a desired position
+# in the document.
+
+sub ScrlToPos
+{
+ my $w = shift;
+ my $pos = shift;
+ my $cmd = $w->cget('-command');
+ return unless (defined $cmd);
+ my @info = $w->get;
+ if (@info == 2)
+ {
+ $cmd->Call('moveto',$pos);
+ }
+ else
+ {
+ $cmd->Call(int($info[0]*$pos));
+ }
+}
+
+# tkScrlTopBottom
+# Scroll to the top or bottom of the document, depending on the mouse
+# position.
+#
+# Arguments:
+# w - The scrollbar widget.
+# x, y - Mouse coordinates within the widget.
+
+sub ScrlTopBottom
+{
+ my $w = shift;
+ my $e = $w->XEvent;
+ my $element = $w->identify($e->x,$e->y);
+ return unless ($element);
+ if ($element =~ /1$/)
+ {
+ $w->ScrlToPos(0);
+ }
+ elsif ($element =~ /2$/)
+ {
+ $w->ScrlToPos(1);
+ }
+}
+
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm
new file mode 100644
index 00000000000..673a1e181ce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm
@@ -0,0 +1,115 @@
+package Tk::Spinbox;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d',q$Revision: #6 $ =~ /#(\d+)/;
+
+use base 'Tk::Entry';
+
+sub Tk_cmd { \&Tk::spinbox }
+
+# Also inherits Entry's methods
+Tk::Methods( "identify", "invoke", "set" );
+use Tk::Submethods ( 'selection' => ["element"] );
+
+Construct Tk::Widget 'Spinbox';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class, '<Up>', [invoke => 'buttonup']);
+ $mw->bind($class, '<4>', [invoke => 'buttonup']);
+ $mw->bind($class, '<Down>',[invoke => 'buttondown']);
+ $mw->bind($class, '<5>', [invoke => 'buttondown']);
+
+ return $class;
+}
+
+sub Invoke
+{
+ my ($w,$elem) = @_;
+ unless ($w->{_outside})
+ {
+ $w->invoke($elem);
+ $w->{_repeated}++;
+ }
+ my $delay = $w->cget('-repeatinterval');
+ if ($delay > 0)
+ {
+ $w->RepeatId($w->after($delay,[Invoke => $w,$elem]));
+ }
+}
+
+sub Button1
+{
+ my ($w,$x,$y) = @_;
+ my $elem = $w->identify($x,$y);
+ $w->{_element} = $elem || 'entry';
+ if ($w->{_element} eq 'entry')
+ {
+ $w->SUPER::Button1($x,$y);
+ }
+ elsif ($w->cget('-state') ne 'disabled')
+ {
+ $w->selectionElement($elem);
+ $w->{_repeated} = 0;
+ $w->{_outside} = 0;
+ $w->{_relief} = $w->cget("-${elem}relief");
+ $w->CancelRepeat;
+ my $delay = $w->cget('-repeatdelay');
+ $w->RepeatId($w->after($delay,[Invoke => $w,$elem])) if $delay > 0;
+ }
+}
+
+sub Motion
+{
+ my ($w,$x,$y) = @_;
+ my $elem = $w->identify($x,$y);
+ $w->{_element} = $elem || 'entry' unless $w->{_element};
+ if ($w->{_element} eq 'entry')
+ {
+ $w->SUPER::Motion($x,$y);
+ }
+ else
+ {
+ if (!defined($elem) || $elem ne $w->{_element})
+ {
+ # Moved outside the button
+ unless ($w->{_outside})
+ {
+ $w->{_outside} = 1;
+ $w->selectionElement('none');
+ }
+ }
+ elsif ($w->{_outside})
+ {
+ # Moved back over the button
+ $w->selectionElement($elem);
+ $w->{_outside} = 0;
+ }
+ }
+}
+
+sub Button1Release
+{
+ my ($w,$x,$y) = @_;
+ $w->SUPER::Button1Release($x,$y);
+ my $elem = $w->{_element};
+ if (defined($elem) && $elem ne 'entry')
+ {
+ my $repeated = $w->{_repeated};
+ if (defined($repeated) && !$repeated)
+ {
+ $w->invoke($elem);
+ }
+ my $relief = delete $w->{_relief};
+ $w->configure("-${elem}relief",$relief) if $relief
+ }
+ $w->selectionElement('none');
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Stats.pm b/Master/tlpkg/tlperl/lib/Tk/Stats.pm
new file mode 100644
index 00000000000..39bedfb1a47
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Stats.pm
@@ -0,0 +1,26 @@
+package Tk::Stats;
+
+($lu,$ls) = times;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Stats.pm#4 $
+
+sub stats
+ {
+ my ($u,$s) = times;
+ my $du = $u-$lu;
+ my $ds = $s-$ls;
+ $ls = $s;
+ $lu = $u;
+ print sprintf(' dt=%4.2f du=%4.2f ds=%4.2f',$du+$ds,$du,$ds);
+ print sprintf(' t=%4.2f u=%4.2f s=%4.2f',$u+$s,$u,$s);
+ print ' ',shift,"\n";
+ }
+
+sub import
+{
+ stats($_[1]);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Submethods.pm b/Master/tlpkg/tlperl/lib/Tk/Submethods.pm
new file mode 100644
index 00000000000..a2b8e3bd186
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Submethods.pm
@@ -0,0 +1,46 @@
+package Tk::Submethods;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ foreach my $sub (@{$sm})
+ {
+ my ($suffix) = $sub =~ /(\w+)$/;
+ my $pfn = $package.'::'.$fn;
+ *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) };
+ }
+ }
+}
+
+sub Direct
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ my $sub;
+ foreach $sub (@{$sm})
+ {
+ # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }";
+ *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) };
+ }
+ }
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/TList.pm b/Master/tlpkg/tlperl/lib/Tk/TList.pm
new file mode 100644
index 00000000000..65ce18796bb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TList.pm
@@ -0,0 +1,416 @@
+package Tk::TList;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/TList/TList.pm#6 $
+
+use Tk qw(Ev $XS_VERSION);
+
+use base qw(Tk::Widget);
+
+use strict;
+
+Construct Tk::Widget 'TList';
+
+bootstrap Tk::TList;
+
+sub Tk_cmd { \&Tk::tlist }
+
+Tk::Methods qw(insert index anchor delete dragsite dropsite entrycget
+ entryconfigure info nearest see selection xview yview);
+
+use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
+ 'info' => [qw(anchor dragsite dropsite selection)],
+ 'selection' => [qw(clear get includes set)],
+ 'anchor' => [qw(clear set)],
+ 'dragsite' => [qw(clear set)],
+ 'dropsite' => [qw(clear set)],
+ );
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
+ $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
+ $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+ $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
+ $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
+
+ $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
+
+ $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
+ $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
+ $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
+
+ $mw->bind($class,'<B1-Enter>','B1_Enter');
+
+ $mw->bind($class,'<Up>', ['DirKey', 'up']);
+ $mw->bind($class,'<Down>',['DirKey', 'down']);
+
+ $mw->bind($class,'<Left>', ['DirKey', 'left']);
+ $mw->bind($class,'<Right>',['DirKey', 'right']);
+
+ $mw->bind($class,'<Prior>','Prior');
+ $mw->bind($class,'<Next>','Next');
+
+ $mw->bind($class,'<Return>', ['KeyboardActivate']);
+ $mw->bind($class,'<space>', ['KeyboardBrowse']);
+
+ return $class;
+}
+
+sub Control_ButtonRelease_1
+{
+}
+
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+ $w->ButtonRelease1($Ev);
+}
+
+
+sub Control_B1_Motion
+{
+}
+
+
+sub B1_Enter
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat
+ if($w->cget('-selectmode') ne 'dragdrop');
+}
+
+
+sub Prior
+{
+shift->yview('scroll', -1, 'pages')
+}
+
+
+sub Next
+{
+shift->yview('scroll', 1, 'pages')
+}
+
+
+sub Button1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ $w->focus()
+ if($w->cget('-takefocus'));
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+ # $w->Send_WaitDrag($Ev->y);
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->x, $Ev->y);
+
+ return unless defined $ent;
+
+ my $browse = 0;
+
+ if($mode eq 'single')
+ {
+ $w->anchor('set', $ent);
+ }
+ elsif($mode eq 'browse')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear' );
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selection('clear');
+ $w->anchor('set', $ent);
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+ $browse = 1;
+ }
+
+ $w->Callback(-browsecmd => $ent) if ($browse);
+}
+
+sub ShiftButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ my $to = $w->GetNearest($Ev->x,$Ev->y);
+
+ delete $w->{'shiftanchor'};
+
+ return unless defined $to;
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if (defined $from)
+ {
+ $w->selection('clear');
+ $w->selection('set', $from, $to);
+ }
+ else
+ {
+ $w->anchor('set', $to);
+ $w->selection('clear');
+ $w->selection('set', $to);
+ }
+ }
+}
+
+sub GetNearest
+{
+ my ($w,$x,$y) = @_;
+ my $ent = $w->nearest($x,$y);
+ if (defined $ent)
+ {
+ my $state = $w->entrycget($ent, '-state');
+ return $ent if (!defined($state) || $state ne 'disabled');
+ }
+ return undef;
+}
+
+sub ButtonRelease1
+{
+ my ($w, $Ev) = @_;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'dragdrop')
+ {
+# $w->Send_DoneDrag();
+ return;
+ }
+
+ my ($x, $y) = ($Ev->x, $Ev->y);
+ my $ent = $w->GetNearest($x,$y);
+
+ return unless defined $ent;
+
+ if($x < 0 || $y < 0 || $x > $w->width || $y > $w->height)
+ {
+ $w->selection('clear');
+
+ return if($mode eq 'single' || $mode eq 'browse')
+
+ }
+ else
+ {
+ if($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+
+ }
+ elsif($mode eq 'multiple')
+ {
+ $w->selection('set', $ent);
+ }
+ elsif($mode eq 'extended')
+ {
+ $w->selection('set', $ent);
+ }
+ }
+
+ $w->Callback(-browsecmd =>$ent);
+}
+
+sub Button1Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'dragdrop')
+ {
+# $w->Send_StartDrag();
+ return;
+ }
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ if($mode eq 'single')
+ {
+ $w->anchor('set', $ent);
+ }
+ elsif($mode eq 'multiple' || $mode eq 'extended')
+ {
+ my $from = $w->info('anchor');
+ if (defined $from)
+ {
+ $w->selection('clear');
+ $w->selection('set', $from, $ent);
+ }
+ else
+ {
+ $w->anchor('set', $ent);
+ $w->selection('clear');
+ $w->selection('set', $ent);
+ }
+ }
+
+ if($mode ne 'single')
+ {
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub Double1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ $w->anchor('set', $ent) unless defined($w->info('anchor'));
+
+ $w->selection('set', $ent);
+ $w->Callback(-command => $ent);
+}
+
+sub CtrlButton1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+
+ delete $w->{'shiftanchor'};
+
+ my $ent = $w->GetNearest($Ev->x,$Ev->y);
+
+ return unless defined $ent;
+
+ my $mode = $w->cget('-selectmode');
+
+ if($mode eq 'extended')
+ {
+ $w->anchor('set', $ent) unless defined( $w->info('anchor') );
+
+ if($w->selection('includes', $ent))
+ {
+ $w->selection('clear', $ent);
+ }
+ else
+ {
+ $w->selection('set', $ent);
+ }
+ $w->Callback(-browsecmd =>$ent);
+ }
+}
+
+sub DirKey
+{
+ my ($w,$dir) = @_;
+ my $anchor = $w->info('anchor');
+
+ my $new = (defined $anchor) ? $w->info($dir,$anchor) : 0;
+
+ $w->anchorSet($new);
+ $w->see($new);
+}
+
+sub KeyboardActivate
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless defined $anchor;
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selection('clear');
+ $w->selection('set', $anchor);
+ }
+ $w->Callback(-command => $anchor);
+}
+
+sub KeyboardBrowse
+{
+ my $w = shift;
+
+ my $anchor = $w->info('anchor');
+
+ return unless defined $anchor;
+
+ if($w->cget('-selectmode'))
+ {
+ $w->selection('clear');
+ $w->selection('set', $anchor);
+ }
+ $w->Callback(-browsecmd =>$anchor);
+}
+
+sub AutoScan
+{
+ my $w = shift;
+
+ return if($w->cget('-selectmode') eq 'dragdrop');
+
+ my $Ev = $w->XEvent;
+ my $y = $Ev->y;
+ my $x = $Ev->x;
+
+ if($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ }
+ elsif($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ }
+ elsif($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ }
+ elsif($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ }
+ else
+ {
+ return;
+ }
+ $w->RepeatId($w->after(50,[AutoScan => $w]));
+ $w->Button1Motion;
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Table.pm b/Master/tlpkg/tlperl/lib/Tk/Table.pm
new file mode 100644
index 00000000000..8fa9e5af4a9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Table.pm
@@ -0,0 +1,598 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Table;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Pretty;
+use AutoLoader;
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Table';
+
+# Constants for QueueLayout flags
+sub _SlaveSize () { 1 } # Slave has asked for change of width or height
+sub _SlaveChange () { 2 } # We lost or gained a slave
+sub _ViewChange () { 4 } # xview or yview called
+sub _ConfigEvent () { 8 } # Table has changed size
+sub _ScrollBars () { 32 } # Scrollabrs came or went
+sub _RowColCount () { 16 } # rows or columns configured
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',_ConfigEvent]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->XYscrollBind($class);
+ return $class;
+}
+
+sub _view
+{
+ my ($t,$s,$page,$a,$op,$num,$type) = @_;
+ if ($op eq 'moveto')
+ {
+ $$s = int(@$a*$num);
+ }
+ else
+ {
+ $num *= ($page/2) if ($type eq 'pages');
+ $$s += $num;
+ }
+ $$s = 0 if ($$s < 0);
+ $t->QueueLayout(_ViewChange);
+}
+
+sub xview
+{
+ my $t = shift;
+ $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_);
+}
+
+sub yview
+{
+ my $t = shift;
+ $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_);
+}
+
+sub FocusChildren
+{
+ my $t = shift;
+ return () if ($t->cget('-takefocus'));
+ return $t->SUPER::FocusChildren;
+}
+
+sub Populate
+{
+ my ($t,$args) = @_;
+ $t->SUPER::Populate($args);
+ $t->ConfigSpecs('-scrollbars' => [METHOD => 'scrollbars','Scrollbars','nw'],
+ '-takefocus' => [SELF => 'takeFocus','TakeFocus',1],
+ '-rows' => [METHOD => 'rows','Rows',10],
+ '-fixedrows' => [METHOD => 'fixedRows','FixedRows',0],
+ '-columns' => [METHOD => 'columns','Columns',10],
+ '-fixedcolumns' => [METHOD => 'fixedColumn','FixedColumns',0],
+ '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2]
+ );
+ $t->_init;
+}
+
+sub sizeN
+{
+ my ($n,$a) = @_;
+ my $max = 0;
+ my $i = 0;
+ my $sum = 0;
+ while ($i < @$a && $i < $n)
+ {
+ my $n = $a->[$i++];
+ $a->[$i-1] = $n = 0 unless (defined $n);
+ $sum += $n;
+ }
+ $max = $sum if ($sum > $max);
+ while ($i < @$a)
+ {
+ $sum = $sum-$a->[$i-$n]+$a->[$i];
+ $max = $sum if ($sum > $max);
+ $i++;
+ }
+ return $max;
+}
+
+sub total
+{
+ my ($a) = @_;
+ my $total = 0;
+ my $x;
+ foreach $x (@{$a})
+ {
+ $total += $x;
+ }
+ return $total;
+}
+
+sub constrain
+{
+ my ($sb,$a,$pixels,$fixed) = @_;
+ my $n = $$sb+$fixed;
+ my $total = 0;
+ my $i;
+ $n = @$a if ($n > @$a);
+ $n = $fixed if ($n < $fixed);
+ for ($i= 0; $i < $fixed; $i++)
+ {
+ (defined($a->[$i])) && ($total += $a->[$i]);
+ }
+ for ($i=$n; $total < $pixels && $i < @$a; $i++)
+ {
+ $a->[$i] ||= 0;
+ $total += $a->[$i];
+ }
+ while ($n > $fixed)
+ {
+ if (($total += $a->[--$n]) > $pixels)
+ {
+ $n++;
+ last;
+ }
+ }
+ $$sb = $n-$fixed;
+}
+
+sub Layout
+{
+ my ($t) = @_;
+ return unless Tk::Exists($t);
+ my $rows = @{$t->{Row}};
+ my $bw = $t->cget(-highlightthickness);
+ my $frows = $t->cget(-fixedrows);
+ my $fcols = $t->cget(-fixedcolumns);
+ my $sb = $t->cget(-scrollbars);
+ my $H = $t->Height;
+ my $W = $t->Width;
+ my $tadj = $bw;
+ my $badj = $bw;
+ my $ladj = $bw;
+ my $radj = $bw;
+ my @xs = ($W,0,0,0);
+ my @ys = (0,$H,0,0);
+ my $xsb;
+ my $ysb;
+
+ my $why = $t->{LayoutPending};
+ $t->{LayoutPending} = 0;
+
+ if ($sb =~ /[ns]/)
+ {
+ $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb});
+ $xsb = $t->{xsb};
+ $xs[3] = $xsb->ReqHeight;
+ if ($sb =~ /n/)
+ {
+ $xs[1] = $tadj;
+ $tadj += $xs[3];
+ }
+ else
+ {
+ $badj += $xs[3];
+ $xs[1] = $H-$badj;
+ }
+ }
+ else
+ {
+ $t->{xsb}->UnmapWindow if (defined $t->{xsb});
+ }
+
+ if ($sb =~ /[ew]/)
+ {
+ $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb});
+ $ysb = $t->{ysb};
+ $ys[2] = $ysb->ReqWidth;
+ if ($sb =~ /w/)
+ {
+ $ys[0] = $ladj;
+ $ladj += $ys[2];
+ }
+ else
+ {
+ $radj += $ys[2];
+ $ys[0] = $W-$radj;
+ }
+ }
+ else
+ {
+ $t->{ysb}->UnmapWindow if (defined $t->{ysb});
+ }
+
+ constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows);
+ constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols);
+
+ my $top = $t->{Top}+$frows;
+ my $left = $t->{Left}+$fcols;
+
+ if ($why & (_ScrollBars|_RowColCount|_SlaveSize))
+ {
+ # Width and/or Height of element or
+ # number of rows and/or columns or
+ # scrollbar presence has changed
+ my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj;
+ my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj;
+ $t->GeometryRequest($w,$h);
+ }
+
+ if ($rows)
+ {
+ my $cols = @{$t->{Width}};
+ my $yhwm = $top-$frows;
+ my $xhwm = $left-$fcols;
+ my $y = $tadj;
+ my $r;
+ for ($r = 0; $r < $rows; $r++)
+ {
+ my $h = $t->{Height}[$r];
+ next unless defined $h;
+ if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj))
+ {
+ if (defined $t->{Row}[$r])
+ {
+ my $c;
+ for ($c = 0; $c < @{$t->{Row}[$r]}; $c++)
+ {
+ my $s = $t->{Row}[$r][$c];
+ if (defined $s)
+ {
+ $s->UnmapWindow;
+ if ($why & 1)
+ {
+ my $w = $t->{Width}[$c];
+ $s->ResizeWindow($w,$h);
+ }
+ }
+ }
+ }
+ }
+ else
+ {
+ my $hwm = $left-$fcols;
+ my $sh = 0;
+ my $x = $ladj;
+ my $c;
+ $ys[1] = $y if ($y < $ys[1] && $r >= $frows);
+ for ($c = 0; $c <$cols; $c++)
+ {
+ my $s = $t->{Row}[$r][$c];
+ my $w = $t->{Width}[$c];
+ if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) )
+ {
+ if (defined $s)
+ {
+ $s->UnmapWindow;
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ }
+ else
+ {
+ $xs[0] = $x if ($x < $xs[0] && $c >= $fcols);
+ if (defined $s)
+ {
+ if ($why & 1)
+ {
+ $s->MoveResizeWindow($x,$y,$w,$h);
+ }
+ else
+ {
+ $s->MoveWindow($x,$y);
+ }
+ $s->MapWindow;
+ }
+ $x += $w;
+ if ($c >= $fcols)
+ {
+ $hwm++;
+ $sh += $w
+ }
+ }
+ }
+ $xhwm = $hwm if ($hwm > $xhwm);
+ $xs[2] = $sh if ($sh > $xs[2]);
+ $y += $h;
+ if ($r >= $frows)
+ {
+ $ys[3] += $h;
+ $yhwm++;
+ }
+ }
+ }
+ $t->{Bottom} = $yhwm;
+ $t->{Right} = $xhwm;
+ if (defined $xsb && $xs[2] > 0)
+ {
+ $xsb->MoveResizeWindow(@xs);
+ $cols -= $fcols;
+ if ($cols > 0)
+ {
+ $xsb->set($t->{Left}/$cols,$t->{Right}/$cols);
+ $xsb->MapWindow;
+ }
+ }
+ if (defined $ysb && $ys[3] > 0)
+ {
+ $ysb->MoveResizeWindow(@ys);
+ $rows -= $frows;
+ if ($rows > 0)
+ {
+ $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows);
+ $ysb->MapWindow;
+ }
+ }
+ }
+}
+
+sub QueueLayout
+{
+ my ($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub SlaveGeometryRequest
+{
+ my ($m,$s) = @_;
+ my ($row,$col) = @{$m->{Slave}{$s->PathName}};
+ my $sw = $s->ReqWidth;
+ my $sh = $s->ReqHeight;
+ my $sz = 0;
+ if ($sw > $m->{Width}[$col])
+ {
+ $m->{Width}[$col] = $sw;
+ $m->QueueLayout(_SlaveSize);
+ $sz++;
+ }
+ if ( (not defined ($m->{Height}[$row])) or $sh > $m->{Height}[$row])
+ {
+ $m->{Height}[$row] = $sh;
+ $m->QueueLayout(_SlaveSize);
+ $sz++;
+ }
+ if (!$sz)
+ {
+ $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]);
+ }
+}
+
+sub get
+{
+ my ($t,$row,$col) = @_;
+ return $t->{Row}[$row][$col];
+}
+
+sub LostSlave
+{
+ my ($t,$s) = @_;
+ my $info = delete $t->{Slave}{$s->PathName};
+ if (defined $info)
+ {
+ my ($row,$col) = @$info;
+ $t->{Row}[$row][$col] = undef;
+ $s->UnmapWindow;
+ }
+ else
+ {
+ $t->BackTrace('Cannot find' . $s->PathName);
+ }
+ $t->QueueLayout(_SlaveChange);
+}
+
+sub clear {
+ my $self = shift;
+ my $rows = $self->cget(-rows);
+ my $cols = $self->cget(-columns);
+ foreach my $r (1 .. $rows) {
+ foreach my $c (1 .. $cols) {
+ my $old = $self->get( $r, $c );
+ next unless $old;
+ $self->LostSlave($old);
+ $old->destroy;
+ }
+ }
+ $self->_init;
+ $self->QueueLayout(_SlaveSize);
+}
+
+sub _init {
+ my $self = shift;
+ $self->{'Width'} = [];
+ $self->{'Height'} = [];
+ $self->{'Row'} = [];
+ $self->{'Slave'} = {};
+ $self->{'Top'} = 0;
+ $self->{'Left'} = 0;
+ $self->{'Bottom'} = 0;
+ $self->{'Right'} = 0;
+ $self->{LayoutPending} = 0;
+}
+
+sub put
+{
+ my ($t,$row,$col,$w) = @_;
+ $w = $t->Label(-text => $w) unless (ref $w);
+ $t->ManageGeometry($w);
+ unless (defined $t->{Row}[$row])
+ {
+ $t->{Row}[$row] = [];
+ $t->{Height}[$row] = 0;
+ }
+ unless (defined $t->{Width}[$col])
+ {
+ $t->{Width}[$col] = 0;
+ }
+ my $old = $t->{Row}[$row][$col];
+ if (defined $old)
+ {
+ $old->UnmanageGeometry;
+ $t->LostSlave($old);
+ }
+ $t->{Row}[$row][$col] = $w;
+ $t->{Slave}{$w->PathName} = [$row,$col];
+ $t->SlaveGeometryRequest($w);
+ $t->QueueLayout(_SlaveChange);
+ return $old;
+}
+
+#
+# configure methods
+#
+
+sub scrollbars
+{
+ my ($t,$v) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-scrollbars => $v);
+ $t->QueueLayout(_ScrollBars);
+ }
+ return $t->_cget('-scrollbars');
+}
+
+sub rows
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-rows => $r);
+ if ($t->{Row} && @{$t->{Row}} > $r)
+ {
+ for my $y ($r .. $#{$t->{Row}})
+ {
+ for my $s (@{$t->{Row}[$y]})
+ {
+ $s->destroy if $s;
+ }
+ }
+ splice @{ $t->{Row} }, $r;
+ }
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-rows');
+}
+
+sub fixedrows
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-fixedrows => $r);
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-fixedrows');
+}
+
+sub columns
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-columns => $r);
+ if ($t->{Row})
+ {
+ for my $row (@{$t->{Row}})
+ {
+ for my $s (@$row[$r .. $#$row])
+ {
+ $s->destroy if $s;
+ }
+ { # FIXME? - Steve was getting warnings :
+ # splice() offset past end of array
+ local $^W = 0;
+ splice @$row, $r;
+ }
+ }
+ }
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-columns');
+}
+
+sub fixedcolumns
+{
+ my ($t,$r) = @_;
+ if (@_ > 1)
+ {
+ $t->_configure(-fixedcolumns => $r);
+ $t->QueueLayout(_RowColCount);
+ }
+ return $t->_cget('-fixedcolumns');
+}
+
+1;
+__END__
+sub Create
+{
+ my $t = shift;
+ my $r = shift;
+ my $c = shift;
+ my $kind = shift;
+ $t->put($r,$c,$t->$kind(@_));
+}
+
+sub totalColumns
+{
+ scalar @{shift->{'Width'}};
+}
+
+sub totalRows
+{
+ scalar @{shift->{'Height'}};
+}
+
+sub Posn
+{
+ my ($t,$s) = @_;
+ my $info = $t->{Slave}{$s->PathName};
+ return (wantarray) ? @$info : $info;
+}
+
+sub see
+{
+ my $t = shift;
+ my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}};
+ my $see = 1;
+ if (($row -= $t->cget('-fixedrows')) >= 0)
+ {
+ if ($row < $t->{Top})
+ {
+ $t->{Top} = $row;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($row >= $t->{Bottom})
+ {
+ $t->{Top} += ($row - $t->{Bottom}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ if (($col -= $t->cget('-fixedcolumns')) >= 0)
+ {
+ if ($col < $t->{Left})
+ {
+ $t->{Left} = $col;
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ elsif ($col >= $t->{Right})
+ {
+ $t->{Left} += ($col - $t->{Right}+1);
+ $t->QueueLayout(_ViewChange);
+ $see = 0;
+ }
+ }
+ return $see;
+}
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Text.pm b/Master/tlpkg/tlperl/lib/Tk/Text.pm
new file mode 100644
index 00000000000..fe0aa0bf4c1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Text.pm
@@ -0,0 +1,1653 @@
+# text.tcl --
+#
+# This file defines the default bindings for Tk text widgets.
+#
+# @(#) text.tcl 1.18 94/12/17 16:05:26
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# perl/Tk version:
+# Copyright (c) 1995-2004 Nick Ing-Simmons
+# Copyright (c) 1999 Greg London
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package Tk::Text;
+use AutoLoader;
+use Carp;
+use strict;
+
+use Text::Tabs;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+use base qw(Tk::Clipboard Tk::Widget);
+
+Construct Tk::Widget 'Text';
+
+bootstrap Tk::Text;
+
+sub Tk_cmd { \&Tk::text }
+
+sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }
+
+Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump','edit',
+ 'get','image','index','insert','mark','scan','search',
+ 'see','tag','window','xview','yview');
+
+use Tk::Submethods ( 'mark' => [qw(gravity names next previous set unset)],
+ 'scan' => [qw(mark dragto)],
+ 'tag' => [qw(add bind cget configure delete lower
+ names nextrange prevrange raise ranges remove)],
+ 'window' => [qw(cget configure create names)],
+ 'image' => [qw(cget configure create names)],
+ 'xview' => [qw(moveto scroll)],
+ 'yview' => [qw(moveto scroll)],
+ 'edit' => [qw(modified redo reset separator undo)],
+ );
+
+sub Tag;
+sub Tags;
+
+sub bindRdOnly
+{
+
+ my ($class,$mw) = @_;
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<Meta-B1-Motion>','NoOp');
+ $mw->bind($class,'<Meta-1>','NoOp');
+ $mw->bind($class,'<Alt-KeyPress>','NoOp');
+ $mw->bind($class,'<Escape>','unselectAll');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
+ $mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
+ $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);
+
+ $mw->bind($class,'<Double-1>','selectWord' ) ;
+ $mw->bind($class,'<Triple-1>','selectLine' ) ;
+ $mw->bind($class,'<Shift-1>','adjustSelect' ) ;
+ $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
+ $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);
+
+ $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);
+
+ $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);
+
+ $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
+ $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);
+
+ $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
+ $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);
+
+ $mw->bind($class,'<Home>',['SetCursor','insert linestart']);
+ $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
+ $mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
+ $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);
+
+ $mw->bind($class,'<End>',['SetCursor','insert lineend']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
+ $mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
+ $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);
+
+ $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);
+
+ $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
+ $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);
+
+ $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
+ $mw->bind($class,'<Control-Tab>','focusNext');
+ $mw->bind($class,'<Control-Shift-Tab>','focusPrev');
+
+ $mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Select>',['markSet','anchor','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
+ $mw->bind($class,'<Control-slash>','selectAll');
+ $mw->bind($class,'<Control-backslash>','unselectAll');
+
+ if (!$Tk::strictMotif)
+ {
+ $mw->bind($class,'<Control-a>', ['SetCursor','insert linestart']);
+ $mw->bind($class,'<Control-b>', ['SetCursor','insert-1c']);
+ $mw->bind($class,'<Control-e>', ['SetCursor','insert lineend']);
+ $mw->bind($class,'<Control-f>', ['SetCursor','insert+1c']);
+ $mw->bind($class,'<Meta-b>', ['SetCursor','insert-1c wordstart']);
+ $mw->bind($class,'<Meta-f>', ['SetCursor','insert wordend']);
+ $mw->bind($class,'<Meta-less>', ['SetCursor','1.0']);
+ $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']);
+
+ $mw->bind($class,'<Control-n>', ['SetCursor',Ev('UpDownLine',1)]);
+ $mw->bind($class,'<Control-p>', ['SetCursor',Ev('UpDownLine',-1)]);
+
+ $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]);
+ }
+ $mw->bind($class,'<Destroy>','Destroy');
+ $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')] );
+ $mw->YMouseWheelBind($class);
+ $mw->XMouseWheelBind($class);
+
+ $mw->MouseWheelBind($class);
+
+ return $class;
+}
+
+sub selectAll
+{
+ my ($w) = @_;
+ $w->tagAdd('sel','1.0','end');
+}
+
+sub unselectAll
+{
+ my ($w) = @_;
+ $w->tagRemove('sel','1.0','end');
+}
+
+sub adjustSelect
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->ResetAnchor($Ev->xy);
+ $w->SelectTo($Ev->xy,'char')
+}
+
+sub selectLine
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'line');
+ Tk::catch { $w->markSet('insert','sel.first') };
+}
+
+sub selectWord
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $w->SelectTo($Ev->xy,'word');
+ Tk::catch { $w->markSet('insert','sel.first') }
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $class->bindRdOnly($mw);
+
+ $mw->bind($class,'<Tab>', 'insertTab');
+ $mw->bind($class,'<Control-i>', ['Insert',"\t"]);
+ $mw->bind($class,'<Return>', ['Insert',"\n"]);
+ $mw->bind($class,'<Delete>','Delete');
+ $mw->bind($class,'<BackSpace>','Backspace');
+ $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ;
+ $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]);
+
+ $mw->bind($class,'<F1>', 'clipboardColumnCopy');
+ $mw->bind($class,'<F2>', 'clipboardColumnCut');
+ $mw->bind($class,'<F3>', 'clipboardColumnPaste');
+
+ # Additional emacs-like bindings:
+
+ if (!$Tk::strictMotif)
+ {
+ $mw->bind($class,'<Control-d>',['delete','insert']);
+ $mw->bind($class,'<Control-k>','deleteToEndofLine') ;
+ $mw->bind($class,'<Control-o>','openLine');
+ $mw->bind($class,'<Control-t>','Transpose');
+ $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']);
+ $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']);
+
+ # A few additional bindings of my own.
+ $mw->bind($class,'<Control-h>','deleteBefore');
+ $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2');
+ }
+#JD# $Tk::prevPos = undef;
+ return $class;
+}
+
+sub insertTab
+{
+ my ($w) = @_;
+ $w->Insert("\t");
+ $w->focus;
+ $w->break
+}
+
+sub deleteToEndofLine
+{
+ my ($w) = @_;
+ if ($w->compare('insert','==','insert lineend'))
+ {
+ $w->delete('insert')
+ }
+ else
+ {
+ $w->delete('insert','insert lineend')
+ }
+}
+
+sub openLine
+{
+ my ($w) = @_;
+ $w->insert('insert',"\n");
+ $w->markSet('insert','insert-1c')
+}
+
+sub Button2
+{
+ my ($w,$x,$y) = @_;
+ $w->scan('mark',$x,$y);
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $Tk::mouseMoved = 0;
+}
+
+sub Motion2
+{
+ my ($w,$x,$y) = @_;
+ $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
+ $w->scan('dragto',$x,$y) if ($Tk::mouseMoved);
+}
+
+sub ButtonRelease2
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) }
+ }
+}
+
+sub InsertSelection
+{
+ my ($w) = @_;
+ Tk::catch { $w->Insert($w->SelectionGet) }
+}
+
+sub Backspace
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+ {
+ $w->delete('sel.first','sel.last');
+ return;
+ }
+ $w->deleteBefore;
+}
+
+sub deleteBefore
+{
+ my ($w) = @_;
+ if ($w->compare('insert','!=','1.0'))
+ {
+ $w->delete('insert-1c');
+ $w->see('insert')
+ }
+}
+
+sub Delete
+{
+ my ($w) = @_;
+ my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
+ if (defined $sel)
+ {
+ $w->delete('sel.first','sel.last')
+ }
+ else
+ {
+ $w->delete('insert');
+ $w->see('insert')
+ }
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in text
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# x - The x-coordinate of the button press.
+# y - The x-coordinate of the button press.
+sub Button1
+{
+ my ($w,$x,$y) = @_;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $w->SetCursor('@'.$x.','.$y);
+ $w->markSet('anchor','insert');
+ $w->focus() if ($w->cget('-state') eq 'normal');
+}
+
+sub B1_Motion
+{
+ my ($w) = @_;
+ return unless defined $Tk::mouseMoved;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->SelectTo($Ev->xy)
+}
+
+sub B1_Leave
+{
+ my ($w) = @_;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $w->AutoScan;
+}
+
+# SelectTo --
+# This procedure is invoked to extend the selection, typically when
+# dragging it with the mouse. Depending on the selection mode (character,
+# word, line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The text window in which the button was pressed.
+# index - Index of character at which the mouse button was pressed.
+sub SelectTo
+{
+ my ($w, $index, $mode)= @_;
+ $Tk::selectMode = $mode if defined ($mode);
+ my $cur = $w->index($index);
+ my $anchor = Tk::catch { $w->index('anchor') };
+ if (!defined $anchor)
+ {
+ $w->markSet('anchor',$anchor = $cur);
+ $Tk::mouseMoved = 0;
+ }
+ elsif ($w->compare($cur,'!=',$anchor))
+ {
+ $Tk::mouseMoved = 1;
+ }
+ $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
+ $mode = $Tk::selectMode;
+ my ($first,$last);
+ if ($mode eq 'char')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $cur;
+ $last = 'anchor';
+ }
+ else
+ {
+ $first = 'anchor';
+ $last = $cur
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $w->index("$cur wordstart");
+ $last = $w->index('anchor - 1c wordend')
+ }
+ else
+ {
+ $first = $w->index('anchor wordstart');
+ $last = $w->index("$cur wordend")
+ }
+ }
+ elsif ($mode eq 'line')
+ {
+ if ($w->compare($cur,'<','anchor'))
+ {
+ $first = $w->index("$cur linestart");
+ $last = $w->index('anchor - 1c lineend + 1c')
+ }
+ else
+ {
+ $first = $w->index('anchor linestart');
+ $last = $w->index("$cur lineend + 1c")
+ }
+ }
+ if ($Tk::mouseMoved || $Tk::selectMode ne 'char')
+ {
+ $w->tagRemove('sel','1.0',$first);
+ $w->tagAdd('sel',$first,$last);
+ $w->tagRemove('sel',$last,'end');
+ $w->idletasks;
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves a text window
+# with button 1 down. It scrolls the window up, down, left, or right,
+# depending on where the mouse is (this information was saved in
+# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after'
+# command so that the window continues to scroll until the mouse
+# moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The text window.
+sub AutoScan
+{
+ my ($w) = @_;
+ if ($Tk::y >= $w->height)
+ {
+ $w->yview('scroll',2,'units')
+ }
+ elsif ($Tk::y < 0)
+ {
+ $w->yview('scroll',-2,'units')
+ }
+ elsif ($Tk::x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($Tk::x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->SelectTo('@' . $Tk::x . ','. $Tk::y);
+ $w->RepeatId($w->after(50,['AutoScan',$w]));
+}
+# SetCursor
+# Move the insertion cursor to a given position in a text. Also
+# clears the selection, if there is one in the text, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The text window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my ($w,$pos) = @_;
+ $pos = 'end - 1 chars' if $w->compare($pos,'==','end');
+ $w->markSet('insert',$pos);
+ $w->unselectAll;
+ $w->see('insert');
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The text window.
+# new - A new position for the insertion cursor (the cursor has not
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my ($w,$new) = @_;
+ my ($first,$last);
+ if (!defined $w->tag('ranges','sel'))
+ {
+ # No selection yet
+ $w->markSet('anchor','insert');
+ if ($w->compare($new,'<','insert'))
+ {
+ $w->tagAdd('sel',$new,'insert')
+ }
+ else
+ {
+ $w->tagAdd('sel','insert',$new)
+ }
+ }
+ else
+ {
+ # Selection exists
+ if ($w->compare($new,'<','anchor'))
+ {
+ $first = $new;
+ $last = 'anchor'
+ }
+ else
+ {
+ $first = 'anchor';
+ $last = $new
+ }
+ $w->tagRemove('sel','1.0',$first);
+ $w->tagAdd('sel',$first,$last);
+ $w->tagRemove('sel',$last,'end')
+ }
+ $w->markSet('insert',$new);
+ $w->see('insert');
+ $w->idletasks;
+}
+# ResetAnchor --
+# Set the selection anchor to whichever end is farthest from the
+# index argument. One special trick: if the selection has two or
+# fewer characters, just leave the anchor where it is. In this
+# case it does not matter which point gets chosen for the anchor,
+# and for the things like Shift-Left and Shift-Right this produces
+# better behavior when the cursor moves back and forth across the
+# anchor.
+#
+# Arguments:
+# w - The text widget.
+# index - Position at which mouse button was pressed, which determines
+# which end of selection should be used as anchor point.
+sub ResetAnchor
+{
+ my ($w,$index) = @_;
+ if (!defined $w->tag('ranges','sel'))
+ {
+ $w->markSet('anchor',$index);
+ return;
+ }
+ my $a = $w->index($index);
+ my $b = $w->index('sel.first');
+ my $c = $w->index('sel.last');
+ if ($w->compare($a,'<',$b))
+ {
+ $w->markSet('anchor','sel.last');
+ return;
+ }
+ if ($w->compare($a,'>',$c))
+ {
+ $w->markSet('anchor','sel.first');
+ return;
+ }
+ my ($lineA,$chA) = split(/\./,$a);
+ my ($lineB,$chB) = split(/\./,$b);
+ my ($lineC,$chC) = split(/\./,$c);
+ if ($lineB < $lineC+2)
+ {
+ my $total = length($w->get($b,$c));
+ if ($total <= 2)
+ {
+ return;
+ }
+ if (length($w->get($b,$a)) < $total/2)
+ {
+ $w->markSet('anchor','sel.last')
+ }
+ else
+ {
+ $w->markSet('anchor','sel.first')
+ }
+ return;
+ }
+ if ($lineA-$lineB < $lineC-$lineA)
+ {
+ $w->markSet('anchor','sel.last')
+ }
+ else
+ {
+ $w->markSet('anchor','sel.first')
+ }
+}
+
+########################################################################
+sub markExists
+{
+ my ($w, $markname)=@_;
+ my $mark_exists=0;
+ my @markNames_list = $w->markNames;
+ foreach my $mark (@markNames_list)
+ { if ($markname eq $mark) {$mark_exists=1;last;} }
+ return $mark_exists;
+}
+
+########################################################################
+sub OverstrikeMode
+{
+ my ($w,$mode) = @_;
+
+ $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'});
+
+ $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1);
+
+ return $w->{'OVERSTRIKE_MODE'};
+}
+
+########################################################################
+# pressed the <Insert> key, just above 'Del' key.
+# this toggles between insert mode and overstrike mode.
+sub ToggleInsertMode
+{
+ my ($w)=@_;
+ $w->OverstrikeMode(!$w->OverstrikeMode);
+}
+
+########################################################################
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ return unless length($char);
+ if ($w->OverstrikeMode)
+ {
+ my $current=$w->get('insert');
+ $w->delete('insert') unless($current eq "\n");
+ }
+ $w->Insert($char);
+}
+
+########################################################################
+sub GotoLineNumber
+{
+ my ($w,$line_number) = @_;
+ $line_number=~ s/^\s+|\s+$//g;
+ return if $line_number =~ m/\D/;
+ my ($last_line,$junk) = split(/\./, $w->index('end'));
+ if ($line_number > $last_line) {$line_number = $last_line; }
+ $w->{'LAST_GOTO_LINE'} = $line_number;
+ $w->markSet('insert', $line_number.'.0');
+ $w->see('insert');
+}
+
+########################################################################
+sub GotoLineNumberPopUp
+{
+ my ($w)=@_;
+ my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'};
+
+ unless (defined($w->{'LAST_GOTO_LINE'}))
+ {
+ my ($line,$col) = split(/\./, $w->index('insert'));
+ $w->{'LAST_GOTO_LINE'} = $line;
+ }
+
+ ## if anything is selected when bring up the pop-up, put it in entry window.
+ my $selected;
+ eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ unless ($@)
+ {
+ if (defined($selected) and length($selected))
+ {
+ unless ($selected =~ /\D/)
+ {
+ $w->{'LAST_GOTO_LINE'} = $selected;
+ }
+ }
+ }
+ unless (defined($popup))
+ {
+ require Tk::DialogBox;
+ $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w,
+ -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'});
+ $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup;
+ $popup->resizable('no','no');
+ my $frame = $popup->Frame->pack(-fill => 'x');
+ $frame->Label(-text=>'Enter line number: ')->pack(-side => 'left');
+ my $entry = $frame->Entry(-background=>'white', -width=>25,
+ -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x');
+ $popup->Advertise(entry => $entry);
+ }
+ $popup->Popup;
+ $popup->Subwidget('entry')->focus;
+ $popup->Wait;
+}
+
+########################################################################
+
+sub getSelected
+{
+ shift->GetTextTaggedWith('sel');
+}
+
+sub deleteSelected
+{
+ shift->DeleteTextTaggedWith('sel');
+}
+
+sub GetTextTaggedWith
+{
+ my ($w,$tag) = @_;
+
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+ my $return_text='';
+
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return $return_text;}
+
+ # for every range-pair, get selected text
+ while(@ranges)
+ {
+ my $first = shift(@ranges);
+ my $last = shift(@ranges);
+ my $text = $w->get($first , $last);
+ if(defined($text))
+ {$return_text = $return_text . $text;}
+ # if there is more tagged text, separate with an end of line character
+ if(@ranges)
+ {$return_text = $return_text . "\n";}
+ }
+ return $return_text;
+}
+
+########################################################################
+sub DeleteTextTaggedWith
+{
+ my ($w,$tag) = @_;
+ my @ranges = $w->tagRanges($tag);
+ my $range_total = @ranges;
+
+ # if nothing tagged with that tag, then ignore
+ if ($range_total == 0) {return;}
+
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markSet('mark_tag_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ for (my $i=0; $i<$range_total; $i=$i+2)
+ {
+ my $first = $w->index('mark_tag_'.$i);
+ my $last = $w->index('mark_tag_'.($i+1));
+
+ my $text = $w->delete($first , $last);
+ }
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markUnset('mark_tag_'.$i); }
+}
+
+
+########################################################################
+sub FindAll
+{
+ my ($w,$mode, $case, $pattern ) = @_;
+ ### 'sel' tags accumulate, need to remove any previous existing
+ $w->unselectAll;
+
+ my $match_length=0;
+ my $start_index;
+ my $end_index = '1.0';
+
+ while(defined($end_index))
+ {
+ if ($case eq '-nocase')
+ {
+ $start_index = $w->search(
+ $mode,
+ $case,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ $end_index,
+ 'end');
+ }
+ else
+ {
+ $start_index = $w->search(
+ $mode,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ $end_index,
+ 'end');
+ }
+
+ unless(defined($start_index) && $start_index) {last;}
+
+ my ($line,$col) = split(/\./, $start_index);
+ $col = $col + $match_length;
+ $end_index = $line.'.'.$col;
+ $w->tagAdd('sel', $start_index, $end_index);
+ }
+}
+
+########################################################################
+# get current selected text and search for the next occurrence
+sub FindSelectionNext
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-forward', '-exact', '-case', $selected);
+}
+
+########################################################################
+# get current selected text and search for the previous occurrence
+sub FindSelectionPrevious
+{
+ my ($w) = @_;
+ my $selected;
+ eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
+ return if($@);
+ return unless (defined($selected) and length($selected));
+
+ $w->FindNext('-backward', '-exact', '-case', $selected);
+}
+
+
+
+########################################################################
+sub FindNext
+{
+ my ($w,$direction, $mode, $case, $pattern ) = @_;
+
+ ## if searching forward, start search at end of selected block
+ ## if backward, start search from start of selected block.
+ ## dont want search to find currently selected text.
+ ## tag 'sel' may not be defined, use eval loop to trap error
+ eval {
+ if ($direction eq '-forward')
+ {
+ $w->markSet('insert', 'sel.last');
+ $w->markSet('current', 'sel.last');
+ }
+ else
+ {
+ $w->markSet('insert', 'sel.first');
+ $w->markSet('current', 'sel.first');
+ }
+ };
+
+ my $saved_index=$w->index('insert');
+
+ # remove any previous existing tags
+ $w->unselectAll;
+
+ my $match_length=0;
+ my $start_index;
+
+ if ($case eq '-nocase')
+ {
+ $start_index = $w->search(
+ $direction,
+ $mode,
+ $case,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ 'insert');
+ }
+ else
+ {
+ $start_index = $w->search(
+ $direction,
+ $mode,
+ -count => \$match_length,
+ "--",
+ $pattern ,
+ 'insert');
+ }
+
+ unless(defined($start_index)) { return 0; }
+ if(length($start_index) == 0) { return 0; }
+
+ my ($line,$col) = split(/\./, $start_index);
+ $col = $col + $match_length;
+ my $end_index = $line.'.'.$col;
+ $w->tagAdd('sel', $start_index, $end_index);
+
+ $w->see($start_index);
+
+ if ($direction eq '-forward')
+ {
+ $w->markSet('insert', $end_index);
+ $w->markSet('current', $end_index);
+ }
+ else
+ {
+ $w->markSet('insert', $start_index);
+ $w->markSet('current', $start_index);
+ }
+
+ my $compared_index = $w->index('insert');
+
+ my $ret_val;
+ if ($compared_index eq $saved_index)
+ {$ret_val=0;}
+ else
+ {$ret_val=1;}
+ return $ret_val;
+}
+
+########################################################################
+sub FindAndReplaceAll
+{
+ my ($w,$mode, $case, $find, $replace ) = @_;
+ $w->markSet('insert', '1.0');
+ $w->unselectAll;
+ while($w->FindNext('-forward', $mode, $case, $find))
+ {
+ $w->ReplaceSelectionsWith($replace);
+ }
+}
+
+########################################################################
+sub ReplaceSelectionsWith
+{
+ my ($w,$new_text ) = @_;
+
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+
+ # if nothing selected, then ignore
+ if ($range_total == 0) {return};
+
+ # insert marks where selections are located
+ # marks will move with text even as text is inserted and deleted
+ # in a previous selection.
+ for (my $i=0; $i<$range_total; $i++)
+ {$w->markSet('mark_sel_'.$i => $ranges[$i]); }
+
+ # for every selected mark pair, insert new text and delete old text
+ my ($first, $last);
+ for (my $i=0; $i<$range_total; $i=$i+2)
+ {
+ $first = $w->index('mark_sel_'.$i);
+ $last = $w->index('mark_sel_'.($i+1));
+
+ ##########################################################################
+ # eventually, want to be able to get selected text,
+ # support regular expression matching, determine replace_text
+ # $replace_text = $selected_text=~m/$new_text/ (or whatever would work)
+ # will have to pass in mode and case flags.
+ # this would allow a regular expression search and replace to be performed
+ # example, look for "line (\d+):" and replace with "$1 >" or similar
+ ##########################################################################
+
+ $w->insert($last, $new_text);
+ $w->delete($first, $last);
+
+ }
+ ############################################################
+ # set the insert cursor to the end of the last insertion mark
+ $w->markSet('insert',$w->index('mark_sel_'.($range_total-1)));
+
+ # delete the marks
+ for (my $i=0; $i<$range_total; $i++)
+ { $w->markUnset('mark_sel_'.$i); }
+}
+########################################################################
+sub FindAndReplacePopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(0);
+}
+
+########################################################################
+sub FindPopUp
+{
+ my ($w)=@_;
+ $w->findandreplacepopup(1);
+}
+
+########################################################################
+
+sub findandreplacepopup
+{
+ my ($w,$find_only)=@_;
+
+ my $pop = $w->Toplevel;
+ $pop->transient($w->toplevel);
+ if ($find_only)
+ { $pop->title("Find"); }
+ else
+ { $pop->title("Find and/or Replace"); }
+ my $frame = $pop->Frame->pack(-anchor=>'nw');
+
+ $frame->Label(-text=>"Direction:")
+ ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw');
+ my $direction = '-forward';
+ $frame->Radiobutton(
+ -variable => \$direction,
+ -text => 'forward',-value => '-forward' )
+ ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$direction,
+ -text => 'backward',-value => '-backward' )
+ ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(-text=>"Mode:")
+ ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw');
+ my $mode = '-exact';
+ $frame->Radiobutton(
+ -variable => \$mode, -text => 'exact',-value => '-exact' )
+ ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$mode, -text => 'regexp',-value => '-regexp' )
+ ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw');
+
+ $frame->Label(-text=>"Case:")
+ ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw');
+ my $case = '-case';
+ $frame->Radiobutton(
+ -variable => \$case, -text => 'case',-value => '-case' )
+ ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw');
+ $frame->Radiobutton(
+ -variable => \$case, -text => 'nocase',-value => '-nocase' )
+ ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw');
+
+ ######################################################
+ my $find_entry = $pop->Entry(-width=>25);
+ $find_entry->focus;
+
+ my $donext = sub {$w->FindNext ($direction,$mode,$case,$find_entry->get())};
+
+ $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing
+
+ ###### if any $w text is selected, put it in the find entry
+ ###### could be more than one text block selected, get first selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+ {
+ my $first = shift(@ranges);
+ my $last = shift(@ranges);
+
+ # limit to one line
+ my ($first_line, $first_col) = split(/\./,$first);
+ my ($last_line, $last_col) = split(/\./,$last);
+ unless($first_line == $last_line)
+ {$last = $first. ' lineend';}
+
+ $find_entry->insert('insert', $w->get($first , $last));
+ }
+ else
+ {
+ my $selected;
+ eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); };
+ if($@) {}
+ elsif (defined($selected))
+ {$find_entry->insert('insert', $selected);}
+ }
+
+ $find_entry->icursor(0);
+
+ my ($replace_entry,$button_replace,$button_replace_all);
+ unless ($find_only)
+ {
+ $replace_entry = $pop->Entry(-width=>25);
+
+ $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
+ }
+
+
+ my $button_find = $pop->Button(-text=>'Find', -command => $donext, -default => 'active')
+ -> pack(-side => 'left');
+
+ my $button_find_all = $pop->Button(-text=>'Find All',
+ -command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
+ ->pack(-side => 'left');
+
+ unless ($find_only)
+ {
+ $button_replace = $pop->Button(-text=>'Replace', -default => 'normal',
+ -command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
+ -> pack(-side =>'left');
+ $button_replace_all = $pop->Button(-text=>'Replace All',
+ -command => sub {$w->FindAndReplaceAll
+ ($mode,$case,$find_entry->get(),$replace_entry->get());} )
+ ->pack(-side => 'left');
+ }
+
+
+ my $button_cancel = $pop->Button(-text=>'Cancel',
+ -command => sub {$pop->destroy()} )
+ ->pack(-side => 'left');
+
+ $find_entry->bind("<Return>" => [$button_find, 'invoke']);
+ $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
+
+ $find_entry->bind("<Return>" => [$button_find, 'invoke']);
+ $find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
+
+ $pop->resizable('yes','no');
+ return $pop;
+}
+
+# paste clipboard into current location
+sub clipboardPaste
+{
+ my ($w) = @_;
+ local $@;
+ Tk::catch { $w->Insert($w->clipboardGet) };
+}
+
+########################################################################
+# Insert --
+# Insert a string into a text at the point of the insertion cursor.
+# If there is a selection in the text, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The text window in which to insert the string
+# string - The string to insert (usually just a single character)
+sub Insert
+{
+ my ($w,$string) = @_;
+ return unless (defined $string && $string ne '');
+ #figure out if cursor is inside a selection
+ my @ranges = $w->tagRanges('sel');
+ if (@ranges)
+ {
+ while (@ranges)
+ {
+ my ($first,$last) = splice(@ranges,0,2);
+ if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert'))
+ {
+ $w->ReplaceSelectionsWith($string);
+ return;
+ }
+ }
+ }
+ # paste it at the current cursor location
+ $w->insert('insert',$string);
+ $w->see('insert');
+}
+
+# UpDownLine --
+# Returns the index of the character one *display* line above or below the
+# insertion cursor. There are two tricky things here. First,
+# we want to maintain the original column across repeated operations,
+# even though some lines that will get passed through do not have
+# enough characters to cover the original column. Second, do not
+# try to scroll past the beginning or end of the text.
+#
+# This may have some weirdness associated with a proportional font. Ie.
+# the insertion cursor will zigzag up or down according to the width of
+# the character at destination.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# n - The number of lines to move: -1 for up one line,
+# +1 for down one line.
+sub UpDownLine
+{
+my ($w,$n) = @_;
+$w->see('insert');
+my $i = $w->index('insert');
+
+my ($line,$char) = split(/\./,$i);
+
+my $testX; #used to check the "new" position
+my $testY; #used to check the "new" position
+
+(my $bx, my $by, my $bw, my $bh) = $w->bbox($i);
+(my $lx, my $ly, my $lw, my $lh) = $w->dlineinfo($i);
+
+if ( ($n == -1) and ($by <= $bh) )
+ {
+ #On first display line.. so scroll up and recalculate..
+ $w->yview('scroll', -1, 'units');
+ unless (($w->yview)[0]) {
+ #first line of entire text - keep same position.
+ return $i;
+ }
+ ($bx, $by, $bw, $bh) = $w->bbox($i);
+ ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
+ }
+elsif ( ($n == 1) and
+ ($ly + $lh) > ( $w->height - 2*$w->cget(-bd) - 2*$w->cget(-highlightthickness) ) )
+ {
+ #On last display line.. so scroll down and recalculate..
+ $w->yview('scroll', 1, 'units');
+ ($bx, $by, $bw, $bh) = $w->bbox($i);
+ ($lx, $ly, $lw, $lh) = $w->dlineinfo($i);
+ }
+
+# Calculate the vertical position of the next display line
+my $Yoffset = 0;
+$Yoffset = $by - $ly + 1 if ($n== -1);
+$Yoffset = $ly + $lh + 1 - $by if ($n == 1);
+$Yoffset*=$n;
+$testY = $by + $Yoffset;
+
+# Save the original 'x' position of the insert cursor if:
+# 1. This is the first time through -- or --
+# 2. The insert cursor position has changed from the previous
+# time the up or down key was pressed -- or --
+# 3. The cursor has reached the beginning or end of the widget.
+
+if (not defined $w->{'origx'} or ($w->{'lastindex'} != $i) )
+ {
+ $w->{'origx'} = $bx;
+ }
+
+# Try to keep the same column if possible
+$testX = $w->{'origx'};
+
+# Get the coordinates of the possible new position
+my $testindex = $w->index('@'.$testX.','.$testY );
+$w->see($testindex);
+my ($nx,$ny,$nw,$nh) = $w->bbox($testindex);
+
+# Which side of the character should we position the cursor -
+# mainly for a proportional font
+if ($testX > $nx+$nw/2)
+ {
+ $testX = $nx+$nw+1;
+ }
+
+my $newindex = $w->index('@'.$testX.','.$testY );
+
+if ( $w->compare($newindex,'==','end - 1 char') and ($ny == $ly ) )
+ {
+ # Then we are trying to the 'end' of the text from
+ # the same display line - don't do that
+ return $i;
+ }
+
+$w->{'lastindex'} = $newindex;
+$w->see($newindex);
+return $newindex;
+}
+
+# PrevPara --
+# Returns the index of the beginning of the paragraph just before a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# pos - Position at which to start search.
+sub PrevPara
+{
+ my ($w,$pos) = @_;
+ $pos = $w->index("$pos linestart");
+ while (1)
+ {
+ if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' )
+ {
+ my $string = $w->get($pos,"$pos lineend");
+ if ($string =~ /^(\s)+/)
+ {
+ my $off = length($1);
+ $pos = $w->index("$pos + $off chars")
+ }
+ if ($w->compare($pos,'!=','insert') || $pos eq '1.0')
+ {
+ return $pos;
+ }
+ }
+ $pos = $w->index("$pos - 1 line")
+ }
+}
+# NextPara --
+# Returns the index of the beginning of the paragraph just after a given
+# position in the text (the beginning of a paragraph is the first non-blank
+# character after a blank line).
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# start - Position at which to start search.
+sub NextPara
+{
+ my ($w,$start) = @_;
+ my $pos = $w->index("$start linestart + 1 line");
+ while ($w->get($pos) ne "\n")
+ {
+ if ($w->compare($pos,'==','end'))
+ {
+ return $w->index('end - 1c');
+ }
+ $pos = $w->index("$pos + 1 line")
+ }
+ while ($w->get($pos) eq "\n" )
+ {
+ $pos = $w->index("$pos + 1 line");
+ if ($w->compare($pos,'==','end'))
+ {
+ return $w->index('end - 1c');
+ }
+ }
+ my $string = $w->get($pos,"$pos lineend");
+ if ($string =~ /^(\s+)/)
+ {
+ my $off = length($1);
+ return $w->index("$pos + $off chars");
+ }
+ return $pos;
+}
+# ScrollPages --
+# This is a utility procedure used in bindings for moving up and down
+# pages and possibly extending the selection along the way. It scrolls
+# the view in the widget by the number of pages, and it returns the
+# index of the character that is at the same position in the new view
+# as the insertion cursor used to be in the old view.
+#
+# Arguments:
+# w - The text window in which the cursor is to move.
+# count - Number of pages forward to scroll; may be negative
+# to scroll backwards.
+sub ScrollPages
+{
+ my ($w,$count) = @_;
+ my @bbox = $w->bbox('insert');
+ $w->yview('scroll',$count,'pages');
+ if (!@bbox)
+ {
+ return $w->index('@' . int($w->height/2) . ',' . 0);
+ }
+ my $x = int($bbox[0]+$bbox[2]/2);
+ my $y = int($bbox[1]+$bbox[3]/2);
+ return $w->index('@' . $x . ',' . $y);
+}
+
+sub Contents
+{
+ my $w = shift;
+ if (@_)
+ {
+ $w->delete('1.0','end');
+ $w->insert('end',shift) while (@_);
+ }
+ else
+ {
+ return $w->get('1.0','end');
+ }
+}
+
+sub Destroy
+{
+ my ($w) = @_;
+ delete $w->{_Tags_};
+}
+
+sub Transpose
+{
+ my ($w) = @_;
+ my $pos = 'insert';
+ $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
+ return if ($w->compare("$pos - 1 char",'==','1.0'));
+ my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
+ $w->delete("$pos - 2 char",$pos);
+ $w->insert('insert',$new);
+ $w->see('insert');
+}
+
+sub Tag
+{
+ my $w = shift;
+ my $name = shift;
+ Carp::confess('No args') unless (ref $w and defined $name);
+ $w->{_Tags_} = {} unless (exists $w->{_Tags_});
+ unless (exists $w->{_Tags_}{$name})
+ {
+ require Tk::Text::Tag;
+ $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
+ }
+ $w->{_Tags_}{$name}->configure(@_) if (@_);
+ return $w->{_Tags_}{$name};
+}
+
+sub Tags
+{
+ my ($w,$name) = @_;
+ my @result = ();
+ foreach $name ($w->tagNames(@_))
+ {
+ push(@result,$w->Tag($name));
+ }
+ return @result;
+}
+
+sub TIEHANDLE
+{
+ my ($class,$obj) = @_;
+ return $obj;
+}
+
+sub PRINT
+{
+ my $w = shift;
+ # Find out whether 'end' is displayed at the moment
+ # Retrieve the position of the bottom of the window as
+ # a fraction of the entire contents of the Text widget
+ my $yview = ($w->yview)[1];
+
+ # If $yview is 1.0 this means that 'end' is visible in the window
+ my $update = 0;
+ $update = 1 if $yview == 1.0;
+
+ # Loop over all input strings
+ while (@_)
+ {
+ $w->insert('end',shift);
+ }
+ # Move the window to see the end of the text if required
+ $w->see('end') if $update;
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+sub WhatLineNumberPopUp
+{
+ my ($w)=@_;
+ my ($line,$col) = split(/\./,$w->index('insert'));
+ $w->messageBox(-type => 'Ok', -title => "What Line Number",
+ -message => "The cursor is on line $line (column is $col)");
+}
+
+sub MenuLabels
+{
+ return qw[~File ~Edit ~Search ~View];
+}
+
+sub SearchMenuItems
+{
+ my ($w) = @_;
+ return [
+ ['command'=>'~Find', -command => [$w => 'FindPopUp']],
+ ['command'=>'Find ~Next', -command => [$w => 'FindSelectionNext']],
+ ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']],
+ ['command'=>'~Replace', -command => [$w => 'FindAndReplacePopUp']]
+ ];
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+ my @items = ();
+ foreach my $op ($w->clipEvents)
+ {
+ push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]);
+ }
+ push(@items,
+ '-',
+ ['command'=>'Select All', -command => [$w => 'selectAll']],
+ ['command'=>'Unselect All', -command => [$w => 'unselectAll']],
+ );
+ return \@items;
+}
+
+sub ViewMenuItems
+{
+ my ($w) = @_;
+ my $v;
+ tie $v,'Tk::Configure',$w,'-wrap';
+ return [
+ ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
+ ['command'=>'~Which Line?', -command => [$w => 'WhatLineNumberPopUp']],
+ ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
+ [radiobutton => 'Word', -variable => \$v, -value => 'word'],
+ [radiobutton => 'Character', -variable => \$v, -value => 'char'],
+ [radiobutton => 'None', -variable => \$v, -value => 'none'],
+ ]],
+ ];
+}
+
+########################################################################
+sub clipboardColumnCopy
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(0);
+}
+
+sub clipboardColumnCut
+{
+ my ($w) = @_;
+ $w->Column_Copy_or_Cut(1);
+}
+
+########################################################################
+sub Column_Copy_or_Cut
+{
+ my ($w, $cut) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ # this only makes sense if there is one selected block
+ unless ($range_total==2)
+ {
+ $w->bell;
+ return;
+ }
+
+ my $selection_start_index = shift(@ranges);
+ my $selection_end_index = shift(@ranges);
+
+ my ($start_line, $start_column) = split(/\./, $selection_start_index);
+ my ($end_line, $end_column) = split(/\./, $selection_end_index);
+
+ # correct indices for tabs
+ my $string;
+ $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
+ $string = substr($string, 0, $start_column);
+ $string = expand($string);
+ my $tab_start_column = length($string);
+
+ $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
+ $string = substr($string, 0, $end_column);
+ $string = expand($string);
+ my $tab_end_column = length($string);
+
+ my $length = $tab_end_column - $tab_start_column;
+
+ $selection_start_index = $start_line . '.' . $tab_start_column;
+ $selection_end_index = $end_line . '.' . $tab_end_column;
+
+ # clear the clipboard
+ $w->clipboardClear;
+ my ($clipstring, $startstring, $endstring);
+ my $padded_string = ' 'x$tab_end_column;
+ for(my $line = $start_line; $line <= $end_line; $line++)
+ {
+ $string = $w->get($line.'.0', $line.'.0 lineend');
+ $string = expand($string) . $padded_string;
+ $clipstring = substr($string, $tab_start_column, $length);
+ #$clipstring = unexpand($clipstring);
+ $w->clipboardAppend($clipstring."\n");
+
+ if ($cut)
+ {
+ $startstring = substr($string, 0, $tab_start_column);
+ $startstring = unexpand($startstring);
+ $start_column = length($startstring);
+
+ $endstring = substr($string, 0, $tab_end_column );
+ $endstring = unexpand($endstring);
+ $end_column = length($endstring);
+
+ $w->delete($line.'.'.$start_column, $line.'.'.$end_column);
+ }
+ }
+}
+
+########################################################################
+
+sub clipboardColumnPaste
+{
+ my ($w) = @_;
+ my @ranges = $w->tagRanges('sel');
+ my $range_total = @ranges;
+ if ($range_total)
+ {
+ warn " there cannot be any selections during clipboardColumnPaste. \n";
+ $w->bell;
+ return;
+ }
+
+ my $clipboard_text;
+ eval
+ {
+ $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD");
+ };
+
+ return unless (defined($clipboard_text));
+ return unless (length($clipboard_text));
+ my $string;
+
+ my $current_index = $w->index('insert');
+ my ($current_line, $current_column) = split(/\./,$current_index);
+ $string = $w->get($current_line.'.0', $current_line.'.'.$current_column);
+ $string = expand($string);
+ $current_column = length($string);
+
+ my @clipboard_lines = split(/\n/,$clipboard_text);
+ my $length;
+ my $end_index;
+ my ($delete_start_column, $delete_end_column, $insert_column_index);
+ foreach my $line (@clipboard_lines)
+ {
+ if ($w->OverstrikeMode)
+ {
+ #figure out start and end indexes to delete, compensating for tabs.
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column);
+ $string = unexpand($string);
+ $delete_start_column = length($string);
+
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column + length($line));
+ chomp($string); # dont delete a "\n" on end of line.
+ $string = unexpand($string);
+ $delete_end_column = length($string);
+
+
+
+ $w->delete(
+ $current_line.'.'.$delete_start_column ,
+ $current_line.'.'.$delete_end_column
+ );
+ }
+
+ $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $current_column);
+ $string = unexpand($string);
+ $insert_column_index = length($string);
+
+ $w->insert($current_line.'.'.$insert_column_index, unexpand($line));
+ $current_line++;
+ }
+
+}
+
+# Backward compatibility
+sub GetMenu
+{
+ carp((caller(0))[3]." is deprecated") if $^W;
+ shift->menu
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm
new file mode 100644
index 00000000000..827278eb88c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Text/Tag.pm
@@ -0,0 +1,46 @@
+package Tk::Text::Tag;
+require Tk::Text;
+
+use overload '""' => \&name;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Text/Text/Tag.pm#4 $
+
+sub _apply
+{
+ my $self = shift;
+ my $meth = shift;
+ $self->widget->tag($meth => $self->name,@_);
+}
+
+sub name
+{
+ return shift->[0];
+}
+
+sub widget
+{
+ return shift->[1];
+}
+
+BEGIN
+{
+ my $meth;
+ foreach $meth (qw(cget configure bind add))
+ {
+ *{$meth} = sub { shift->_apply($meth,@_) }
+ }
+}
+
+sub new
+{
+ my $class = shift;
+ my $widget = shift;
+ my $name = shift;
+ my $obj = bless [$name,$widget],$class;
+ $obj->configure(@_) if (@_);
+ return $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm
new file mode 100644
index 00000000000..e1ff20b6149
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TextEdit.pm
@@ -0,0 +1,509 @@
+# Copyright (c) 1999 Greg Bartels. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# Special thanks to Nick Ing-Simmons for pushing a lot of
+# my text edit functionality into Text.pm and TextUndo.pm
+# otherwise, this module would have been monstrous.
+
+# Andy Worhal had it wrong, its "fifteen megabytes of fame"
+# -Greg Bartels
+
+package Tk::TextEdit;
+
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/TextEdit.pm#4 $
+
+use Tk qw (Ev);
+use AutoLoader;
+
+use Text::Tabs;
+
+use base qw(Tk::TextUndo);
+
+Construct Tk::Widget 'TextEdit';
+
+#######################################################################
+#######################################################################
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $mw->bind($class,'<F5>', 'IndentSelectedLines');
+ $mw->bind($class,'<F6>', 'UnindentSelectedLines');
+
+ $mw->bind($class,'<F7>', 'CommentSelectedLines');
+ $mw->bind($class,'<F8>', 'UncommentSelectedLines');
+
+ return $class;
+}
+
+# 8 horizontal pixels in the "space" character in default font.
+my $tab_multiplier = 8;
+
+sub debug_code_f1
+{
+ my $w=shift;
+}
+
+sub debug_code_f2
+{
+ my $w=shift;
+}
+
+#######################################################################
+#######################################################################
+sub InitObject
+{
+ my ($w) = @_;
+ $w->SUPER::InitObject;
+
+ $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" "
+ $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments
+
+ my %pair_descriptor_hash =
+ (
+ 'PARENS' => [ 'multiline', '(', ')', "[()]" ],
+ 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ],
+ 'BRACES' => [ 'multiline', '[', ']', "[][]" ],
+ 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ],
+ 'SINGLEQUOTE' => [ 'singleline', "'","'" ],
+ );
+
+ $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash;
+
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green');
+ $w->tagConfigure
+ ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey');
+
+ $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red');
+ $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red');
+
+ $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS');
+ $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES');
+ $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES');
+ $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE');
+ $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE');
+
+ $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call.
+ $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80;
+ $w->SetGUICallbackIndex(0);
+ $w->schedule_next_callback;
+
+}
+
+#######################################################################
+
+sub cancel_current_gui_callback_and_restart_from_beginning
+{
+ my ($w)=@_;
+ if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'}))
+ {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();}
+ $w->SetGUICallbackIndex(0);
+
+ $w->schedule_next_callback;
+}
+
+sub schedule_next_callback
+{
+ my ($w)=@_;
+ return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call.
+ $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after
+ ($w->{'UPDATE_WIDGET_PERIOD'},
+ sub
+ {
+ $w->CallNextGUICallback;
+ $w->schedule_next_callback;
+ }
+ );
+
+}
+
+
+#######################################################################
+# use these methods to pass the TextEdit widget an anonymous array
+# of code references.
+# any time the widget changes that requires the display to be updated,
+# then these code references will be scheduled in sequence for calling.
+# splitting them up allows them to be prioritized by order,
+# and prevents the widget from "freezing" too long if they were
+# one large callback. scheduling them apart allows the widget time
+# to respond to user inputs.
+#######################################################################
+sub SetGUICallbacks
+{
+ my ($w,$callback_array_ref) = @_;
+ $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref;
+ $w->SetGUICallbackIndex(0);
+}
+
+sub GetGUICallbacks
+{
+ return shift->{GUI_CALLBACK_ARRAY_REF};
+}
+
+sub SetGUICallbackIndex
+{
+ my ($w, $val)=@_;
+ $w->{GUI_CALLBACK_ARRAY_INDEX}=$val;
+}
+
+sub GetGUICallbackIndex
+{
+ return shift->{GUI_CALLBACK_ARRAY_INDEX};
+}
+
+sub IncrementGUICallbackIndex
+{
+ shift->{GUI_CALLBACK_ARRAY_INDEX} += 1;
+}
+
+sub NoMoreGUICallbacksToCall
+{
+ my ($w) = @_;
+ return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF});
+ return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX});
+ my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
+ my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
+ return $arr_ind >= @$arr_ref;
+}
+
+sub CallNextGUICallback
+{
+ my ($w) = @_;
+ return if $w->NoMoreGUICallbacksToCall;
+ my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF};
+ my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX};
+ &{$arr_ref->[$arr_ind]};
+ $w->IncrementGUICallbackIndex;
+}
+
+
+#######################################################################
+#######################################################################
+
+sub insert
+{
+ my $w = shift;
+ $w->SUPER::insert(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub delete
+{
+ my $w = shift;
+ $w->SUPER::delete(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub SetCursor
+{
+ my $w = shift;
+ $w->SUPER::SetCursor(@_);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+}
+
+sub OverstrikeMode
+{
+ my ($w,$mode) = @_;
+ if (defined($mode))
+ {
+ $w->SUPER::OverstrikeMode($mode);
+ $w->cancel_current_gui_callback_and_restart_from_beginning;
+ }
+ return $w->SUPER::OverstrikeMode;
+}
+
+
+#######################################################################
+# use yview on scrollbar to get fractional coordinates.
+# scale this by the total length of the text to find the
+# approximate start line of widget and end line of widget.
+#######################################################################
+sub GetScreenWindowCoordinates
+{
+ my $w = shift;
+ my ($top_frac, $bot_frac) = $w->yview;
+ my $end_index = $w->index('end');
+ my ($lines,$columns) = split (/\./,$end_index);
+ my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'};
+ my $top_line = int(($top_frac * $lines) - $window);
+ $top_line = 0 if ($top_line < 0);
+ my $bot_line = int(($bot_frac * $lines) + $window);
+ $bot_line = $lines if ($bot_line > $lines);
+ my $top_index = $top_line . '.0';
+ my $bot_index = $bot_line . '.0';
+
+ $_[0] = $top_index;
+ $_[1] = $bot_index;
+}
+
+########################################################################
+# take two indices as inputs.
+# if they are on the same line or same column (accounting for tabs)
+# then return 1
+# else return 0
+# (assume indices passed in are in line.column format)
+########################################################################
+sub IndicesLookGood
+{
+ my ($w, $start, $end, $singleline) = @_;
+
+ return 0 unless ( (defined($start)) and (defined($end)));
+
+ my ($start_line, $start_column) = split (/\./,$start);
+ my ($end_line, $end_column) = split (/\./,$end);
+
+ ##########################
+ # good if on the same line
+ ##########################
+ return 1 if ($start_line == $end_line);
+
+ ##########################
+ # if not on same line and its a singleline, its bad
+ ##########################
+ return 0 if $singleline;
+
+
+ # get both lines, convert the tabs to spaces, and get the new column.
+ # see if they line up or not.
+ my $string;
+ $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
+ $string = substr($string, 0, $start_column+1);
+ $string = expand($string);
+ $start_column = length($string);
+
+ $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
+ $string = substr($string, 0, $end_column +1);
+ $string = expand($string);
+ $end_column = length($string);
+
+ ##########################
+ # good if on the same column (adjusting for tabs)
+ ##########################
+ return 1 if ($start_column == $end_column);
+
+ # otherwise its bad
+ return 0;
+}
+
+########################################################################
+# if searching backward, count paranthesis until find a start parenthesis
+# which does not have a forward match.
+#
+# (<= search backward will return this index
+# ()
+# START X HERE
+# ( ( ) () )
+# )<== search forward will return this index
+#
+# if searching forward, count paranthesis until find a end parenthesis
+# which does not have a rearward match.
+########################################################################
+sub searchForBaseCharacterInPair
+{
+ my
+ (
+ $w, $top_index, $searchfromindex, $bot_index,
+ $direction, $startchar, $endchar, $charpair
+ )=@_;
+ my ($plus_one_char, $search_end_index, $index_offset, $done_index);
+ if ($direction eq '-forward')
+ {
+ $plus_one_char = $endchar;
+ $search_end_index = $bot_index;
+ $index_offset = ' +1c';
+ $done_index = $w->index('end');
+ }
+ else
+ {
+ $plus_one_char = $startchar;
+ $search_end_index = $top_index;
+ $index_offset = '';
+ $done_index = '1.0';
+ }
+
+ my $at_done_index = 0;
+ my $count = 0;
+ my $char;
+ while(1)
+ {
+ $searchfromindex = $w->search
+ ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index );
+
+ last unless(defined($searchfromindex));
+ $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c'));
+ if ($char eq $plus_one_char)
+ {$count += 1;}
+ else
+ {$count -= 1;}
+ last if ($count==1);
+ # boundary condition exists when first char in widget is the match char
+ # need to be able to determine if search tried to go past index '1.0'
+ # if so, set index to undef and return.
+ if ( $at_done_index )
+ {
+ $searchfromindex = undef;
+ last;
+ }
+ $at_done_index = 1 if ($searchfromindex eq $done_index);
+ $searchfromindex=$w->index($searchfromindex . $index_offset);
+ }
+ return $searchfromindex;
+}
+
+########################################################################
+# highlight a character pair that most closely brackets the cursor.
+# allows you to pick and choose which ones you want to do.
+########################################################################
+
+sub HighlightParenthesisAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0);
+}
+
+sub HighlightCurlyBracesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0);
+}
+
+sub HighlightBracesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0);
+}
+
+sub HighlightDoubleQuotesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1);
+}
+
+sub HighlightSingleQuotesAroundCursor
+{
+ my ($w)=@_;
+ $w->HighlightSinglePairBracketingCursor
+ ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1);
+}
+
+########################################################################
+# highlight all the character pairs that most closely bracket the cursor.
+########################################################################
+sub HighlightAllPairsBracketingCursor
+{
+ my ($w)=@_;
+ $w->HighlightParenthesisAroundCursor;
+ $w->HighlightCurlyBracesAroundCursor;
+ $w->HighlightBracesAroundCursor;
+ $w->HighlightDoubleQuotesAroundCursor;
+ $w->HighlightSingleQuotesAroundCursor;
+}
+
+########################################################################
+# search for a pair of matching characters that bracket the
+# cursor and tag them with the given tagname.
+# startchar might be '['
+# endchar would then be ']'
+# tagname is a name of a tag, which has already been
+# configured to highlight however the user wants them to behave.
+# error tagname is the tag to highlight the chars with if there
+# is a problem of some kind.
+# singleline indicates whether the character pairs must occur
+# on a single line. quotation marks are single line characters usually.
+########################################################################
+sub HighlightSinglePairBracketingCursor
+{
+ my
+ (
+ $w, $startchar, $endchar, $charpair,
+ $good_tagname, $bad_tagname, $single_line
+ ) = @_;
+ $single_line=0 unless defined($single_line);
+ $w->tagRemove($good_tagname, '1.0','end');
+ $w->tagRemove($bad_tagname, '1.0','end');
+ my $top_index; my $bot_index;
+ my $cursor = $w->index('insert');
+ if ($single_line)
+ {
+ $top_index = $w->index($cursor.' linestart');
+ $bot_index = $w->index($cursor.' lineend');
+ }
+ else
+ {
+ $w->GetScreenWindowCoordinates($top_index, $bot_index);
+ }
+
+ # search backward for the startchar
+ # $top_index, $searchfromindex, $bot_index,
+ # $direction, $startchar, $endchar, $charpair
+
+ my $startindex = $w->searchForBaseCharacterInPair
+ (
+ $top_index, $cursor, $bot_index,
+ '-backward', $startchar, $endchar, $charpair
+ );
+
+ # search forward for the endchar
+ my $endindex = $w->searchForBaseCharacterInPair
+ (
+ $top_index, $cursor, $bot_index,
+ '-forward', $startchar, $endchar, $charpair
+ );
+ return unless ((defined $startindex) and (defined $endindex));
+
+ my $final_tag = $bad_tagname;
+ if ($w->IndicesLookGood( $startindex, $endindex, $single_line))
+ {
+ $final_tag = $good_tagname;
+ }
+
+ $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') );
+ $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') );
+}
+
+####################################################################
+sub IndentSelectedLines
+{
+ my($w)=@_;
+ $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
+}
+
+sub UnindentSelectedLines
+{
+ my($w)=@_;
+ $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'});
+}
+
+sub CommentSelectedLines
+{
+ my($w)=@_;
+ $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
+}
+
+sub UncommentSelectedLines
+{
+ my($w)=@_;
+ $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'});
+}
+
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextList.pm b/Master/tlpkg/tlperl/lib/Tk/TextList.pm
new file mode 100644
index 00000000000..77a48fdf8ce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TextList.pm
@@ -0,0 +1,985 @@
+# Copyright (c) 1999 Greg London. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# code for bindings taken from Listbox.pm
+
+# comments specifying method functionality taken from
+# "Perl/Tk Pocket Reference" by Stephen Lidie.
+
+#######################################################################
+# this module uses a text module as its base class to create a list box.
+# this will allow list box functionality to also have all the functionality
+# of the Text widget.
+#
+# note that most methods use an element number to indicate which
+# element in the list to work on.
+# the exception to this is the tag and mark methods which
+# are dual natured. These methods may accept either the
+# normal element number, or they will also take a element.char index,
+# which would be useful for applying tags to part of a line in the list.
+#
+#######################################################################
+
+package Tk::TextList;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $
+
+#XXXdel: use Tk::Reindex qw(Tk::ROText); #XXXdel: ReindexedROText);
+
+use base qw(Tk::Derived Tk::ReindexedROText );
+
+use Tk qw (Ev);
+
+#XXX del: use base qw(Tk::ReindexedROText);
+
+Construct Tk::Widget 'TextList';
+
+#######################################################################
+# the following line causes Populate to get called
+# @ISA = qw(Tk::Derived ... );
+#######################################################################
+sub Populate
+{
+ my ($w,$args)=@_;
+ my $option=delete $args->{'-selectmode'};
+ $w->SUPER::Populate($args);
+ $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'],
+ -takefocus => ['PASSIVE','takeFocus','TakeFocus',1],
+ -spacing3 => ['SELF', undef, undef, 3],
+ -insertwidth => ['SELF', undef, undef, 0],
+ );
+
+}
+
+#######################################################################
+#######################################################################
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
+
+ $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
+ $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Up>',['UpDown',-1]);
+ $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
+ $mw->bind($class,'<Down>',['UpDown',1]);
+ $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
+
+ $mw->XscrollBind($class);
+ $mw->PriorNextBind($class);
+
+ $mw->bind($class,'<Control-Home>','Cntrl_Home');
+
+ $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
+ $mw->bind($class,'<Control-End>','Cntrl_End');
+
+ $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
+ $class->clipboardOperations($mw,'Copy');
+ $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
+ $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
+ $mw->bind($class,'<Escape>','Cancel');
+ $mw->bind($class,'<Control-slash>','SelectAll');
+ $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
+ ;
+ # Additional Tk bindings that aren't part of the Motif look and feel:
+ $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]);
+ $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]);
+
+ return $class;
+}
+
+#######################################################################
+# set the active element to index
+# "active" is a text "mark" which underlines the marked text.
+#######################################################################
+sub activate
+{
+ my($w,$element)=@_;
+ $element= $w->index($element).'.0';
+ $w->SUPER::tag('remove', '_ACTIVE_TAG', '1.0','end');
+ $w->SUPER::tag('add', '_ACTIVE_TAG',
+ $element.' linestart', $element.' lineend');
+ $w->SUPER::mark('set', 'active', $element);
+}
+
+
+#######################################################################
+# bbox returns a list (x,y,width,height) giving an approximate
+# bounding box of character given by index
+#######################################################################
+sub bbox
+{
+ my($w,$element)=@_;
+ $element=$w->index($element).'.0' unless ($element=~/./);
+ return $w->SUPER::bbox($element);
+}
+
+#######################################################################
+# returns a list of indices of all elements currently selected
+#######################################################################
+sub curselection
+{
+ my ($w)=@_;
+ my @ranges = $w->SUPER::tag('ranges', 'sel');
+ my @selection_list;
+ while (@ranges)
+ {
+ my ($first,$firstcol) = split(/\./,shift(@ranges));
+ my ($last,$lastcol) = split(/\./,shift(@ranges));
+
+ #########################################################################
+ # if previous selection ended on the same line that this selection starts,
+ # then fiddle the numbers so that this line number isnt included twice.
+ #########################################################################
+ if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
+ {
+ $first++; # count this selection starting from the next line.
+ }
+
+ if ($lastcol==0)
+ {
+ $last-=1;
+ }
+
+ #########################################################################
+ # if incrementing $first causes it to be greater than $last,
+ # then do nothing,
+ # else add (first .. last) to list
+ #########################################################################
+ unless ($first>$last)
+ {
+ push(@selection_list, $first .. $last);
+ }
+ }
+ return @selection_list;
+}
+
+
+#######################################################################
+# deletes range of elements from element1 to element2
+# defaults to element1
+#######################################################################
+sub delete
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend');
+}
+
+#######################################################################
+# deletes range of characters from index1 to index2
+# defaults to index1+1c
+# index is line.char notation.
+#######################################################################
+sub deleteChar
+{
+ my ($w, $index1, $index2)=@_;
+ $index1=$w->index($index1);
+ $index2=$index1.' +1c' unless(defined($index2));
+ $index2=$w->index($index2);
+ $w->SUPER::delete($index1, $index2);
+}
+
+#######################################################################
+# returns as a list contents of elements from $element1 to $element2
+# defaults to element1.
+#######################################################################
+sub get
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ my @getlist;
+ for(my $i=$element1; $i<=$element2; $i++)
+ {
+ push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend'));
+ }
+
+ return @getlist;
+}
+
+#######################################################################
+# return text between index1 and index2 which are line.char notation.
+# return value is a single string. index2 defaults to index1+1c
+# index is line.char notation.
+######################################################################
+sub getChar
+{
+ my $w=shift;
+ return $w->SUPER::get(@_);
+}
+
+#######################################################################
+# returns index in number notation
+# this method returns an element number, ie the 5th element.
+#######################################################################
+sub index
+{
+ my ($w,$element)=@_;
+ return undef unless(defined($element));
+ $element .= '.0' unless $element=~/\D/;
+ $element = $w->SUPER::index($element);
+ my($line,$col)=split(/\./,$element);
+ return $line;
+}
+
+#######################################################################
+# returns index in line.char notation
+# this method returns an index specific to a character within an element
+#######################################################################
+sub indexChar
+{
+ my $w=shift;
+ return $w->SUPER::index(@_);
+}
+
+
+#######################################################################
+# inserts specified elements just before element at index
+#######################################################################
+sub insert
+{
+ my $w=shift;
+ my $element=shift;
+ $element=$w->index($element);
+ my $item;
+ while (@_)
+ {
+ $item = shift(@_);
+ $item .= "\n";
+ $w->SUPER::insert($element++.'.0', $item);
+ }
+}
+
+#######################################################################
+# inserts string just before character at index.
+# index is line.char notation.
+#######################################################################
+sub insertChar
+{
+ my $w=shift;
+ $w->SUPER::insert(@_);
+}
+
+
+
+#######################################################################
+# returns index of element nearest to y-coordinate
+#
+# currently not defined
+#######################################################################
+#sub nearest
+#{
+# return undef;
+#}
+
+#######################################################################
+# Sets the selection anchor to element at index
+#######################################################################
+sub selectionAnchor
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ $w->SUPER::mark('set', 'anchor', $element.'.0');
+}
+
+#######################################################################
+# deselects elements between index1 and index2, inclusive
+#######################################################################
+sub selectionClear
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::tag('remove', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
+}
+
+#######################################################################
+# returns 1 if element at index is selected, 0 otherwise.
+#######################################################################
+sub selectionIncludes
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ my @list = $w->curselection;
+ my $line;
+ foreach $line (@list)
+ {
+ if ($line == $element) {return 1;}
+ }
+ return 0;
+}
+
+#######################################################################
+# adds all elements between element1 and element2 inclusive to selection
+#######################################################################
+sub selectionSet
+{
+ my ($w, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $w->SUPER::tag('add', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
+}
+
+#######################################################################
+# for ->selection(option,args) calling convention
+#######################################################################
+sub selection
+{
+# my ($w,$sub)=(shift,"selection".ucfirst(shift));
+# no strict 'refs';
+# # can't use $w->$sub, since it might call overridden method-- bleh
+# &($sub)($w,@_);
+}
+
+
+#######################################################################
+# adjusts the view in window so element at index is completely visible
+#######################################################################
+sub see
+{
+ my ($w, $element)=@_;
+ $element=$w->index($element);
+ $w->SUPER::see($element.'.0');
+}
+
+#######################################################################
+# returns number of elements in listbox
+#######################################################################
+sub size
+{
+ my ($w)=@_;
+ my $element = $w->index('end');
+ # theres a weird thing with the 'end' mark sometimes being on a line
+ # with text, and sometimes being on a line all by itself
+ my ($text) = $w->get($element);
+ if (length($text) == 0)
+ {$element -= 1;}
+ return $element;
+}
+
+
+
+#######################################################################
+# add a tag based on element numbers
+#######################################################################
+sub tagAdd
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1.' lineend' unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ $w->SUPER::tag('add', $tagName, $element1, $element2);
+}
+
+#######################################################################
+# add a tag based on line.char indexes
+#######################################################################
+sub tagAddChar
+{
+ my $w=shift;
+ $w->SUPER::tag('add',@_);
+}
+
+
+#######################################################################
+# remove a tag based on element numbers
+#######################################################################
+sub tagRemove
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1.' lineend' unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ $w->SUPER::tag('remove', 'sel', $element1, $element2);
+}
+
+#######################################################################
+# remove a tag based on line.char indexes
+#######################################################################
+sub tagRemoveChar
+{
+ my $w=shift;
+ $w->SUPER::tag('remove', @_);
+}
+
+
+
+
+#######################################################################
+# perform tagNextRange based on element numbers
+#######################################################################
+sub tagNextRange
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ my $index = $w->SUPER::tag('nextrange', 'sel', $element1, $element2);
+ my ($line,$col)=split(/\./,$index);
+ return $line;
+}
+
+#######################################################################
+# perform tagNextRange based on line.char indexes
+#######################################################################
+sub tagNextRangeChar
+{
+ my $w=shift;
+ $w->SUPER::tag('nextrange', @_);
+}
+
+#######################################################################
+# perform tagPrevRange based on element numbers
+#######################################################################
+sub tagPrevRange
+{
+ my ($w, $tagName, $element1, $element2)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+
+ $element2=$element1 unless(defined($element2));
+ $element2=$w->index($element2);
+ $element2.='.0 lineend +1c';
+
+ my $index = $w->SUPER::tag('prevrange', 'sel', $element1, $element2);
+ my ($line,$col)=split(/\./,$index);
+ return $line;
+}
+
+#######################################################################
+# perform tagPrevRange based on line.char indexes
+#######################################################################
+sub tagPrevRangeChar
+{
+ my $w=shift;
+ $w->SUPER::tag('prevrange', @_);
+}
+
+
+
+#######################################################################
+# perform markSet based on element numbers
+#######################################################################
+sub markSet
+{
+ my ($w,$mark,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ $w->SUPER::mark('set', $element1,$mark);
+}
+
+#######################################################################
+# perform markSet based on line.char indexes
+#######################################################################
+sub markSetChar
+{
+ my $w=shift;
+ $w->SUPER::mark('set', @_);
+}
+
+#######################################################################
+# perform markNext based on element numbers
+#######################################################################
+sub markNext
+{
+ my ($w,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ return $w->SUPER::mark('next', $element1);
+}
+
+#######################################################################
+# perform markNext based on line.char indexes
+#######################################################################
+sub markNextChar
+{
+ my $w=shift;
+ $w->SUPER::mark('next', @_);
+}
+
+
+#######################################################################
+# perform markPrevious based on element numbers
+#######################################################################
+sub markPrevious
+{
+ my ($w,$element1)=@_;
+ $element1=$w->index($element1);
+ $element1.='.0';
+ return $w->SUPER::mark('previous', $element1);
+}
+
+#######################################################################
+# perform markPrevious based on line.char indexes
+#######################################################################
+sub markPreviousChar
+{
+ my $w=shift;
+ $w->SUPER::mark('previous', @_);
+}
+
+
+
+
+sub ButtonRelease_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->CancelRepeat;
+ $w->activate($Ev->xy);
+}
+
+
+sub Cntrl_Home
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate(0);
+ $w->see(0);
+ $w->selectionClear(0,'end');
+ $w->selectionSet(0)
+}
+
+
+sub Cntrl_End
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->activate('end');
+ $w->see('end');
+ $w->selectionClear(0,'end');
+ $w->selectionSet('end')
+}
+
+
+sub Cntrl_backslash
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if ($w->cget('-selectmode') ne 'browse')
+ {
+ $w->selectionClear(0,'end');
+ }
+}
+
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses. It begins
+# the process of making a selection in the listbox. Its exact behavior
+# depends on the selection mode currently in effect for the listbox;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginSelect
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'multiple')
+ {
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+ else
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ my @list = ();
+ $w->{'SELECTION_LIST_REF'} = \@list;
+ $w->{'PREVIOUS_ELEMENT'} = $el
+ }
+ $w->focus if ($w->cget('-takefocus'));
+}
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down. It may move or extend the selection, depending
+# on the listbox's selection mode.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element under the pointer (must be a number).
+sub Motion
+{
+ my $w = shift;
+ my $el = shift;
+ if (defined($w->{'PREVIOUS_ELEMENT'}) && $el == $w->{'PREVIOUS_ELEMENT'})
+ {
+ return;
+ }
+
+ # if no selections, select current
+ if($w->curselection==0)
+ {
+ $w->activate($el);
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ $w->{'PREVIOUS_ELEMENT'}=$el;
+ return;
+ }
+
+ my $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $w->{'PREVIOUS_ELEMENT'} = $el;
+ }
+ elsif ($mode eq 'extended')
+ {
+ my $i = $w->{'PREVIOUS_ELEMENT'};
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionSet('anchor',$el)
+ }
+ else
+ {
+ $w->selectionClear($i,$el);
+ $w->selectionClear('anchor',$el)
+ }
+ while ($i < $el && $i < $anchor)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += 1
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += -1
+ }
+ $w->{'PREVIOUS_ELEMENT'} = $el
+ }
+}
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses. It
+# begins the process of extending a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginExtend
+{
+ my $w = shift;
+ my $el = shift;
+
+ # if no selections, select current
+ if($w->curselection==0)
+ {
+ $w->activate($el);
+ $w->selectionSet($el);
+ $w->selectionAnchor($el);
+ $w->{'PREVIOUS_ELEMENT'}=$el;
+ return;
+ }
+
+ if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+}
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses. It
+# begins the process of toggling a selection in the listbox. Its
+# exact behavior depends on the selection mode currently in effect
+# for the listbox; see the Motif documentation for details.
+#
+# Arguments:
+# w - The listbox widget.
+# el - The element for the selection operation (typically the
+# one under the pointer). Must be in numerical form.
+sub BeginToggle
+{
+ my $w = shift;
+ my $el = shift;
+ if ($w->cget('-selectmode') eq 'extended')
+ {
+ my @list = $w->curselection();
+ $w->{'SELECTION_LIST_REF'} = \@list;
+ $w->{'PREVIOUS_ELEMENT'} = $el;
+ $w->selectionAnchor($el);
+ if ($w->selectionIncludes($el))
+ {
+ $w->selectionClear($el)
+ }
+ else
+ {
+ $w->selectionSet($el)
+ }
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+# y - The y-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ my $x = shift;
+ my $y = shift;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll',1,'units')
+ }
+ elsif ($y < 0)
+ {
+ $w->yview('scroll',-1,'units')
+ }
+ elsif ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->Motion($w->index("@" . $x . ',' . $y));
+ $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
+}
+# UpDown --
+#
+# Moves the location cursor (active element) up or down by one element,
+# and changes the selection if we're in browse or extended selection
+# mode.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub UpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ my $selectmode = $w->cget('-selectmode');
+ if ($selectmode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ elsif ($selectmode eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $w->{'PREVIOUS_ELEMENT'} = $w->index('active');
+ my @list = ();
+ $w->{'SELECTION_LIST_REF'}=\@list;
+ }
+}
+# ExtendUpDown --
+#
+# Does nothing unless we're in extended selection mode; in this
+# case it moves the location cursor (active element) up or down by
+# one element, and extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# amount - +1 to move down one item, -1 to move back one item.
+sub ExtendUpDown
+{
+ my $w = shift;
+ my $amount = shift;
+ if ($w->cget('-selectmode') ne 'extended')
+ {
+ return;
+ }
+ $w->activate($w->index('active')+$amount);
+ $w->see('active');
+ $w->Motion($w->index('active'))
+}
+# DataExtend
+#
+# This procedure is called for key-presses such as Shift-KEndData.
+# If the selection mode isn't multiple or extend then it does nothing.
+# Otherwise it moves the active element to el and, if we're in
+# extended mode, extends the selection to that point.
+#
+# Arguments:
+# w - The listbox widget.
+# el - An integer element number.
+sub DataExtend
+{
+ my $w = shift;
+ my $el = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'extended')
+ {
+ $w->activate($el);
+ $w->see($el);
+ if ($w->selectionIncludes('anchor'))
+ {
+ $w->Motion($el)
+ }
+ }
+ elsif ($mode eq 'multiple')
+ {
+ $w->activate($el);
+ $w->see($el)
+ }
+}
+# Cancel
+#
+# This procedure is invoked to cancel an extended selection in
+# progress. If there is an extended selection in progress, it
+# restores all of the items between the active one and the anchor
+# to their previous selection state.
+#
+# Arguments:
+# w - The listbox widget.
+sub Cancel
+{
+ my $w = shift;
+ if ($w->cget('-selectmode') ne 'extended' || !defined $w->{'PREVIOUS_ELEMENT'})
+ {
+ return;
+ }
+ my $first = $w->index('anchor');
+ my $last = $w->{'PREVIOUS_ELEMENT'};
+ if ($first > $last)
+ {
+ ($first,$last)=($last,$first);
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$first) >= 0)
+ {
+ $w->selectionSet($first)
+ }
+ $first += 1
+ }
+}
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the active element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w - The listbox widget.
+sub SelectAll
+{
+ my $w = shift;
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'single' || $mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ else
+ {
+ $w->selectionSet(0,'end')
+ }
+}
+
+sub SetList
+{
+ my $w = shift;
+ $w->delete(0,'end');
+ $w->insert('end',@_);
+}
+
+sub deleteSelected
+{
+ my $w = shift;
+ my $i;
+ foreach $i (reverse $w->curselection)
+ {
+ $w->delete($i);
+ }
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ my $element = $w->index('active') || $w->index($w->XEvent->xy);
+ my $str;
+ eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
+ return if $@;
+ foreach (split("\n",$str))
+ {
+ $w->insert($element++,$_);
+ }
+}
+
+sub getSelected
+{
+ my ($w) = @_;
+ my $i;
+ my (@result) = ();
+ foreach $i ($w->curselection)
+ {
+ push(@result,$w->get($i));
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
new file mode 100644
index 00000000000..066e4027a3a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
@@ -0,0 +1,1022 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons.
+# Copyright (c) 1999 Greg London.
+# All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::TextUndo;
+
+use vars qw($VERSION $DoDebug);
+$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $
+$DoDebug = 0;
+
+use Tk qw (Ev);
+use AutoLoader;
+
+use Tk::Text ();
+use base qw(Tk::Text);
+
+Construct Tk::Widget 'TextUndo';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<<Undo>>','undo');
+ $mw->bind($class,'<<Redo>>','redo');
+
+ return $class->SUPER::ClassInit($mw);
+}
+
+
+####################################################################
+# methods for manipulating the undo and redo stacks.
+# no one should directly access the stacks except for these methods.
+# everyone else must access the stacks through these methods.
+####################################################################
+sub ResetUndo
+{
+ my ($w) = @_;
+ delete $w->{UNDO};
+ delete $w->{REDO};
+}
+
+sub PushUndo
+{
+ my $w = shift;
+ $w->{UNDO} = [] unless (exists $w->{UNDO});
+ push(@{$w->{UNDO}},@_);
+}
+
+sub PushRedo
+{
+ my $w = shift;
+ $w->{REDO} = [] unless (exists $w->{REDO});
+ push(@{$w->{REDO}},@_);
+}
+
+sub PopUndo
+{
+ my ($w) = @_;
+ return pop(@{$w->{UNDO}}) if defined $w->{UNDO};
+ return undef;
+}
+
+sub PopRedo
+{
+ my ($w) = @_;
+ return pop(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub ShiftRedo
+{
+ my ($w) = @_;
+ return shift(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub numberChanges
+{
+ my ($w) = @_;
+ return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'}));
+ return scalar(@{$w->{'UNDO'}});
+}
+
+sub SizeRedo
+{
+ my ($w) = @_;
+ return 0 unless exists $w->{'REDO'};
+ return scalar(@{$w->{'REDO'}});
+}
+
+sub getUndoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{UNDO});
+ return $w->{UNDO}[$index];
+}
+
+sub getRedoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{REDO});
+ return $w->{REDO}[$index];
+}
+
+####################################################################
+# type "hello there"
+# hello there_
+# hit UNDO
+# hello_
+# type "out"
+# hello out_
+# pressing REDO should not do anything
+# pressing UNDO should make "out" disappear.
+# pressing UNDO should make "there" reappear.
+# pressing UNDO should make "there" disappear.
+# pressing UNDO should make "hello" disappear.
+#
+# if there is anything in REDO stack and
+# the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo)
+# then before performing the current operation
+# take the REDO stack, and put it on UNDO stack
+# such that UNDO/REDO keystrokes will still make logical sense.
+#
+# call this method at the beginning of any overloaded method
+# which adds operations to the undo or redo stacks.
+# it will perform all the magic needed to handle the redo stack.
+####################################################################
+sub CheckForRedoShuffle
+{
+ my ($w) = @_;
+ my $size_redo = $w->SizeRedo;
+ return unless $size_redo && ($w->OperationMode eq 'normal');
+ # local $DoDebug = 1;
+
+ # we are about to 'do' something new, but have something in REDO stack.
+ # The REDOs may conflict with new ops, but we want to preserve them.
+ # So convert them to UNDOs - effectively do them and their inverses
+ # so net effect on the widget is no-change.
+
+ $w->dump_array('StartShuffle');
+
+ $w->OperationMode('REDO_MAGIC');
+ $w->MarkSelectionsSavePositions;
+
+ my @pvtundo;
+
+ # go through REDO array from end downto 0, i.e. pseudo pop
+ # then pretend we did 'redo' get inverse, and push into UNDO array
+ # and 'do' the op.
+ for (my $i=$size_redo-1; $i>=0 ; $i--)
+ {
+ my ($op,@args) = @{$w->getRedoAtIndex($i)};
+ my $op_undo = $op .'_UNDO';
+ # save the inverse of the op on the UNDO array
+ # do this before the re-doing the op - after a 'delete' we cannot see
+ # text we deleted!
+ my $undo = $w->$op_undo(@args);
+ $w->PushUndo($undo);
+ # We must 'do' the operation now so if this is an insert
+ # the text and tags are available for inspection in delete_UNDO, and
+ # indices reflect changes.
+ $w->$op(@args);
+ # Save the undo that will reverse what we just did - it is
+ # on the undo stack but will be tricky to find
+ push(@pvtundo,$undo);
+ }
+
+ # Now shift each item off REDO array until empty
+ # push each item onto UNDO array - this reverses the order
+ # and we are not altering buffer so we cannot look in the
+ # buffer to compute inverses - which is why we saved them above
+
+ while ($w->SizeRedo)
+ {
+ my $ref = $w->ShiftRedo;
+ $w->PushUndo($ref);
+ }
+
+ # Finally undo whatever we did to compensate for doing it
+ # and get buffer back to state it was before we started.
+ while (@pvtundo)
+ {
+ my ($op,@args) = @{pop(@pvtundo)};
+ $w->$op(@args);
+ }
+
+ $w->RestoreSelectionsMarkedSaved;
+ $w->OperationMode('normal');
+ $w->dump_array('EndShuffle');
+}
+
+# sets/returns undo/redo/normal operation mode
+sub OperationMode
+{
+ my ($w,$mode) = @_;
+ $w->{'OPERATION_MODE'} = $mode if (@_ > 1);
+ $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'});
+ return $w->{'OPERATION_MODE'};
+}
+
+####################################################################
+# dump the undo and redo stacks to the screen.
+# used for debug purposes.
+sub dump_array
+{
+ return unless $DoDebug;
+ my ($w,$why) = @_;
+ print "At $why:\n";
+ foreach my $key ('UNDO','REDO')
+ {
+ if (defined($w->{$key}))
+ {
+ print " $key array is:\n";
+ my $array = $w->{$key};
+ foreach my $ref (@$array)
+ {
+ my @items;
+ foreach my $item (@$ref)
+ {
+ my $loc = $item;
+ $loc =~ tr/\n/\^/;
+ push(@items,$loc);
+ }
+ print " [",join(',',@items),"]\n";
+ }
+ }
+ }
+ print "\n";
+}
+
+
+############################################################
+############################################################
+# these are a group of methods used to indicate the start and end of
+# several operations that are to be undo/redo 'ed in a single step.
+#
+# in other words, "glob" a bunch of operations together.
+#
+# for example, a search and replace should be undone with a single
+# keystroke, rather than one keypress undoes the insert and another
+# undoes the delete.
+# all other methods should access the count via these methods.
+# no other method should directly access the {GLOB_COUNT} value directly
+#############################################################
+#############################################################
+
+sub AddOperation
+{
+ my ($w,@operation) = @_;
+ my $mode = $w->OperationMode;
+
+ if ($mode eq 'normal')
+ {$w->PushUndo([@operation]);}
+ elsif ($mode eq 'undo')
+ {$w->PushRedo([@operation]);}
+ elsif ($mode eq 'redo')
+ {$w->PushUndo([@operation]);}
+ else
+ {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";}
+}
+
+sub addGlobStart # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ $w->CheckForRedoShuffle;
+ $w->dump_array('Start'.$who);
+ $w->AddOperation('GlobStart', $who) ;
+}
+
+sub addGlobEnd # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ my $topundo = $w->getUndoAtIndex(-1);
+ if ($topundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ }
+ else
+ {
+ my $nxtundo = $w->getUndoAtIndex(-2);
+ if ($nxtundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ $w->PopUndo;
+ $w->PushUndo($topundo);
+ }
+ else
+ {
+ $w->AddOperation('GlobEnd', $who);
+ }
+ }
+ $w->dump_array('End'.$who);
+}
+
+sub GlobStart
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1;
+}
+
+sub GlobStart_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobEnd_UNDO' unless defined($who);
+ return ['GlobEnd',$who];
+}
+
+sub GlobEnd
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1;
+}
+
+sub GlobEnd_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobStart_UNDO' unless defined($who);
+ return ['GlobStart',$who];
+}
+
+sub GlobCount
+{
+ my ($w,$count) = @_;
+ unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) )
+ {
+ $w->{'GLOB_COUNT'}=0;
+ }
+ if (defined($count))
+ {
+ $w->{'GLOB_COUNT'}=$count;
+ }
+ return $w->{'GLOB_COUNT'};
+}
+
+####################################################################
+# two methods should be used by applications to access undo and redo
+# capability, namely, $w->undo; and $w->redo; methods.
+# these methods undo and redo the last operation, respectively.
+####################################################################
+sub undo
+{
+ my ($w) = @_;
+ $w->dump_array('Start'.'undo');
+ unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty
+ $w->GlobCount(0); #initialize to zero
+ $w->OperationMode('undo');
+ do
+ {
+ my ($op,@args) = @{$w->PopUndo}; # get undo operation, convert ref to array
+ my $undo_op = $op .'_UNDO';
+ $w->PushRedo($w->$undo_op(@args)); # find out how to undo it
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->numberChanges);
+ $w->OperationMode('normal');
+ $w->dump_array('End'.'undo');
+}
+
+sub redo
+{
+ my ($w) = @_;
+ unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty
+ $w->OperationMode('redo');
+ $w->GlobCount(0); #initialize to zero
+ do
+ {
+ my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list
+ my $undo_op = $op .'_UNDO';
+ $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->SizeRedo);
+ $w->OperationMode('normal');
+}
+
+
+############################################################
+# override low level subroutines so that they work with UNDO/REDO capability.
+# every overridden subroutine must also have a corresponding *_UNDO subroutine.
+# the *_UNDO method takes the same parameters in and returns an array reference
+# which is how to undo itself.
+# note that the *_UNDO must receive absolute indexes.
+# ->insert receives 'markname' as the starting index.
+# ->insert must convert 'markname' using $absindex=$w->index('markname')
+# and pass $absindex to ->insert_UNDO.
+############################################################
+
+sub insert
+{
+ my $w = shift;
+ $w->markSet('insert', $w->index(shift) );
+ while(@_)
+ {
+ my $index1 = $w->index('insert');
+ my $string = shift;
+ my $taglist_ref = shift if @_;
+
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref));
+ }
+ $w->markSet('notepos' => $index1);
+ $w->SUPER::insert($index1,$string,$taglist_ref);
+ $w->markSet('insert', $w->index('notepos'));
+ }
+}
+
+sub insert_UNDO
+{
+ my $w = shift;
+ my $index = shift;
+ my $string = '';
+ # This possible call: ->insert (index, string, tag, string, tag...);
+ # if more than one string, keep reading strings in (discarding tags)
+ # until all strings are read in and $string contains entire text inserted.
+ while (@_)
+ {
+ $string .= shift;
+ my $tags = shift if (@_);
+ }
+ # calculate index
+ # possible things to insert:
+ # carriage return
+ # single character (not CR)
+ # single line of characters (not ending in CR)
+ # single line of characters ending with a CR
+ # multi-line characters. last line does not end with CR
+ # multi-line characters, last line does end with CR.
+ my ($line,$col) = split(/\./,$index);
+ if ($string =~ /\n(.*)$/)
+ {
+ $line += $string =~ tr/\n/\n/;
+ $col = length($1);
+ }
+ else
+ {
+ $col += length($string);
+ }
+ return ['delete', $index, $line.'.'.$col];
+}
+
+sub delete
+{
+ my ($w, $start, $stop) = @_;
+ unless(defined($stop))
+ { $stop = $start .'+1c'; }
+ my $index1 = $w->index($start);
+ my $index2 = $w->index($stop);
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->delete_UNDO($index1,$index2));
+ }
+ $w->SUPER::delete($index1,$index2);
+ # why call SetCursor - it has side effects
+ # which cause a whole slew if save/restore hassles ?
+ $w->SetCursor($index1);
+}
+
+sub delete_UNDO
+{
+ my ($w, $index1, $index2) = @_;
+ my %tags;
+ my @result = ( 'insert' => $index1 );
+ my $str = '';
+
+ ###############################################################
+ # get tags in range and return them in a format that
+ # can be inserted.
+ # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]);
+ # note, have to break tags up into sequential order
+ # in reference to _all_ tags.
+ ###############################################################
+
+ $w->dump('-text','-tag', -command => sub {
+ my ($kind,$value,$posn) = @_;
+ if ($kind eq 'text')
+ {
+ $str .= $value;
+ }
+ else
+ {
+ push(@result,$str,[keys %tags]) if (length $str);
+ $str = '';
+ if ($kind eq 'tagon')
+ {
+ $tags{$value} = 1;
+ }
+ elsif ($kind eq 'tagoff')
+ {
+ delete $tags{$value};
+ }
+ }
+ }, $index1, $index2);
+ push(@result,$str,[keys %tags]) if (length $str);
+ return \@result;
+}
+
+############################################################
+# override subroutines which are collections of low level
+# routines executed in sequence.
+# wrap a globstart and globend around the SUPER:: version of routine.
+############################################################
+
+sub ReplaceSelectionsWith
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::ReplaceSelectionsWith(@_);
+ $w->addGlobEnd;
+}
+
+sub FindAndReplaceAll
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::FindAndReplaceAll(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardPaste(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnPaste(@_);
+ $w->addGlobEnd;
+}
+
+# Greg: this method is more tightly coupled to the base class
+# than I would prefer, but I know of no other way to do it.
+
+sub Insert
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ $w->addGlobStart;
+ $w->SUPER::Insert($char);
+ $w->addGlobEnd;
+ $w->see('insert');
+}
+
+
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
+ {
+ my $index = $w->index('insert');
+ my $undo_item = $w->getUndoAtIndex(-1);
+ if (defined($undo_item) &&
+ ($undo_item->[0] eq 'delete') &&
+ ($undo_item->[2] == $index)
+ )
+ {
+ $w->SUPER::insert($index,$char);
+ $undo_item->[2] = $w->index('insert');
+ return;
+ }
+ }
+ $w->addGlobStart;
+ $w->SUPER::InsertKeypress($char);
+ $w->addGlobEnd;
+}
+
+############################################################
+sub TextUndoFileProgress
+{
+ my ($w,$action,$filename,$count,$val,$total) = @_;
+ return unless(defined($filename) and defined($count));
+
+ my $popup = $w->{'FILE_PROGRESS_POP_UP'};
+ unless (defined($popup))
+ {
+ $w->update;
+ $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
+ $popup->transient($w->toplevel);
+ $popup->withdraw;
+ $popup->resizable('no','no');
+ $popup->Label(-textvariable => \$popup->{ACTION})->pack;
+ $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
+ $popup->Label(-textvariable => \$popup->{COUNT})->pack;
+ my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
+ my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
+ $w->{'FILE_PROGRESS_POP_UP'} = $popup;
+ $popup->{PROGBAR} = $i;
+ }
+ $popup->{ACTION} = $action;
+ $popup->{COUNT} = "lines: $count";
+ $popup->{FILENAME} = "Filename: $filename";
+ if (defined($val) && defined($total) && $total != 0)
+ {
+ $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
+ }
+ else
+ {
+ $popup->{PROGBAR}->placeForget;
+ }
+
+ $popup->idletasks;
+ unless ($popup->viewable)
+ {
+ $w->idletasks;
+ $w->toplevel->deiconify unless $w->viewable;
+ $popup->Popup;
+ }
+ $popup->update;
+ return $popup;
+}
+
+sub FileName
+{
+ my ($w,$filename) = @_;
+ if (@_ > 1)
+ {
+ $w->{'FILENAME'}=$filename;
+ }
+ return $w->{'FILENAME'};
+}
+
+sub PerlIO_layers
+{
+ my ($w,$layers) = @_;
+ $w->{PERLIO_LAYERS} = $layers if @_ > 1;
+ return $w->{PERLIO_LAYERS} || '' ;
+}
+
+sub ConfirmDiscard
+{
+ my ($w)=@_;
+ if ($w->numberChanges)
+ {
+ my $ans = $w->messageBox(-icon => 'warning',
+ -type => 'YesNoCancel', -default => 'Yes',
+ -message =>
+"The text has been modified without being saved.
+Save edits?");
+ return 0 if $ans eq 'Cancel';
+ return 0 if ($ans eq 'Yes' && !$w->Save);
+ }
+ return 1;
+}
+
+################################################################################
+# if the file has been modified since being saved, a pop up window will be
+# created, asking the user to confirm whether or not to exit.
+# this allows the user to return to the application and save the file.
+# the code would look something like this:
+#
+# if ($w->user_wants_to_exit)
+# {$w->ConfirmExit;}
+#
+# it is also possible to trap attempts to delete the main window.
+# this allows the ->ConfirmExit method to be called when the main window
+# is attempted to be deleted.
+#
+# $mw->protocol('WM_DELETE_WINDOW'=>
+# sub{$w->ConfirmExit;});
+#
+# finally, it might be desirable to trap Control-C signals at the
+# application level so that ->ConfirmExit is also called.
+#
+# $SIG{INT}= sub{$w->ConfirmExit;};
+#
+################################################################################
+
+sub ConfirmExit
+{
+ my ($w) = @_;
+ $w->toplevel->destroy if $w->ConfirmDiscard;
+}
+
+sub Save
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless defined $filename;
+ return $w->FileSaveAsPopup unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,">$layers",$filename))
+ {
+ my $status;
+ my $count=0;
+ my $index = '1.0';
+ my $progress;
+ my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./;
+ while ($w->compare($index,'<','end'))
+ {
+# my $end = $w->index("$index + 1024 chars");
+ my $end = $w->index("$index lineend +1c");
+ print $file $w->get($index,$end);
+ $index = $end;
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ if (close($file))
+ {
+ $w->ResetUndo;
+ $w->FileName($filename);
+ return 1;
+ }
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+ return 0;
+}
+
+sub Load
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless (defined($filename));
+ return 0 unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->MainWindow->Busy;
+ $w->EmptyDocument;
+ my $count=1;
+ my $progress;
+ while (<$file>)
+ {
+ $w->SUPER::insert('end',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Loading => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ close($file);
+ $progress->withdraw if defined $progress;
+ $w->markSet('insert' => '1.0');
+ $w->FileName($filename);
+ $w->MainWindow->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+sub IncludeFile
+{
+ my ($w,$filename) = @_;
+ unless (defined($filename))
+ {$w->BackTrace("filename not specified"); return;}
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->Busy;
+ my $count=1;
+ $w->addGlobStart;
+ my $progress;
+ while (<$file>)
+ {
+ $w->insert('insert',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress(Including => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ $w->addGlobEnd;
+ close($file);
+ $w->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+# clear document without pushing it into UNDO array, (use SUPER::delete)
+# (using plain delete(1.0,end) on a really big document fills up the undo array)
+# and then clear the Undo and Redo stacks.
+sub EmptyDocument
+{
+ my ($w) = @_;
+ $w->SUPER::delete('1.0','end');
+ $w->ResetUndo;
+ $w->FileName(undef);
+}
+
+sub ConfirmEmptyDocument
+{
+ my ($w)=@_;
+ $w->EmptyDocument if $w->ConfirmDiscard;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [
+ ["command"=>'~Open', -command => [$w => 'FileLoadPopup']],
+ ["command"=>'~Save', -command => [$w => 'Save' ]],
+ ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
+ ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
+ ["command"=>'~Clear', -command => [$w => 'ConfirmEmptyDocument']],
+ "-",@{$w->SUPER::FileMenuItems}
+ ]
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+
+ return [
+ ["command"=>'Undo', -command => [$w => 'undo']],
+ ["command"=>'Redo', -command => [$w => 'redo']],
+ "-",@{$w->SUPER::EditMenuItems}
+ ];
+}
+
+sub CreateFileSelect
+{
+ my $w = shift;
+ my $k = shift;
+ my $name = $w->FileName;
+ my @types = (['All Files', '*']);
+ my $dir = undef;
+ if (defined $name)
+ {
+ require File::Basename;
+ my $sfx;
+ ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
+ #
+ # it should never happen where we have a file suffix and
+ # no file name... but fileparse() screws this up with dotfiles.
+ #
+ if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
+
+ if (defined($sfx) && length($sfx))
+ {
+ unshift(@types,['Similar Files',[$sfx]]);
+ $name .= $sfx;
+ }
+ }
+ return $w->$k(-initialdir => $dir, -initialfile => $name,
+ -filetypes => \@types, @_);
+}
+
+sub FileLoadPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
+ return $w->Load($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub IncludeFilePopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
+ return $w->IncludeFile($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub FileSaveAsPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
+ return $w->Save($name) if defined($name) and length($name);
+ return 0;
+}
+
+
+sub MarkSelectionsSavePositions
+{
+ my ($w)=@_;
+ $w->markSet('MarkInsertSavePosition','insert');
+ my @ranges = $w->tagRanges('sel');
+ my $i = 0;
+ while (@ranges)
+ {
+ my ($start,$end) = splice(@ranges,0,2);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
+ $w->tagRemove('sel',$start,$end);
+ }
+}
+
+sub RestoreSelectionsMarkedSaved
+{
+ my ($w)=@_;
+ my $i = 1;
+ my %mark_hash;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+ $w->tagAdd('sel',$indexstart, $indexend);
+ $w->markUnset($markstart, $markend);
+ }
+ $w->markSet('insert','MarkInsertSavePosition');
+}
+
+####################################################################
+# selected lines may be discontinous sequence.
+sub GetMarkedSelectedLineNumbers
+{
+ my ($w) = @_;
+
+ my $i = 1;
+ my %mark_hash;
+ my @ranges;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+
+ push(@ranges, $indexstart, $indexend);
+ }
+
+ my @selection_list;
+ while (@ranges)
+ {
+ my ($first) = split(/\./,shift(@ranges));
+ my ($last) = split(/\./,shift(@ranges));
+ # if previous selection ended on the same line that this selection starts,
+ # then fiddle the numbers so that this line number isnt included twice.
+ if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
+ {
+ # if this selection ends on the same line its starts, then skip this sel
+ next if ($first == $last);
+ $first++; # count this selection starting from the next line.
+ }
+ push(@selection_list, $first .. $last);
+ }
+ return @selection_list;
+}
+
+sub insertStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ $w->insert($line.'.0', $insert_string);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+sub deleteStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ my $length = length($insert_string);
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ my $start = $line.'.0';
+ my $end = $line.'.'.$length;
+ my $current_text = $w->get($start, $end);
+ next unless ($current_text eq $insert_string);
+ $w->delete($start, $end);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Tiler.pm b/Master/tlpkg/tlperl/lib/Tk/Tiler.pm
new file mode 100644
index 00000000000..1256612f801
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Tiler.pm
@@ -0,0 +1,203 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+# An example of a geometry manager "widget" in perl
+package Tk::Tiler;
+require Tk;
+require Tk::Frame;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Frame);
+
+Construct Tk::Widget 'Tiler';
+sub Tk::Widget::ScrlTiler { shift->Scrolled('Tiler' => @_) }
+
+use Tk::Pretty;
+
+sub FocusChildren
+{
+ return (wantarray) ? () : 0;
+}
+
+sub Populate
+{
+ my ($obj,$args) = @_;
+ $obj->SUPER::Populate($args);
+ $obj->{Slaves} = [];
+ $obj->{LayoutPending} = 0;
+ $obj->{Start} = 0;
+ $obj->{Sw} = 0;
+ $obj->{Sh} = 0;
+ $obj->ConfigSpecs('-takefocus' => ['SELF', 'takeFocus','TakeFocus',1],
+ '-highlightthickness' => ['SELF', 'highlightThickness','HighlightThickness',2],
+ '-yscrollcommand' => ['CALLBACK',undef,undef,undef],
+ '-columns' => ['PASSIVE','columns','Columns',5],
+ '-rows' => ['PASSIVE','rows','Rows',10]
+ );
+ return $obj;
+}
+
+sub change_size
+{
+ my ($w) = shift;
+ my $r = $w->cget('-rows');
+ my $c = $w->cget('-columns');
+ my $bw = $w->cget(-highlightthickness);
+ if (defined $r && defined $c)
+ {
+ $w->GeometryRequest($c*$w->{Sw}+2*$bw,$r*$w->{Sh}+2*$bw);
+ }
+}
+
+sub Layout
+{
+ my $m = shift;
+ my $bw = $m->cget(-highlightthickness);
+ my $why = $m->{LayoutPending};
+ $m->{LayoutPending} = 0;
+ my $W = $m->Width;
+ my $H = $m->Height;
+ my $w = $m->{Sw} || 1; # max width of slave
+ my $h = $m->{Sh} || 1; # max height of slave
+ my $x = $bw;
+ my $y = $bw;
+ my $start = 0;
+ # Set size and position of slaves
+ my $rows = $m->{Rows} = int(($H-2*$bw)/$h) || 1;
+ my $cols = $m->{Cols} = int(($W-2*$bw)/$w) || 1;
+ my $need = $m->{Need} = int( (@{$m->{Slaves}}+$cols-1)/$cols );
+ $m->{Start} = ($need - $rows) if ($m->{Start} + $rows > $need);
+
+ $m->{Start} = 0 if ($m->{Start} < 0);
+ my $row = 0;
+ my @posn = ();
+ my $s;
+ foreach $s (@{$m->{Slaves}})
+ {
+ if ($row < $m->{Start})
+ {
+ $s->UnmapWindow;
+ $x += $w;
+ if ($x+$w+$bw > $W)
+ {
+ $x = $bw;
+ $row++;
+ }
+ }
+ elsif ($y+$h+$bw > $H)
+ {
+ $s->UnmapWindow;
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ else
+ {
+ push(@posn,[$s,$x,$y]);
+ $x += $w;
+ if ($x+$w+$bw > $W)
+ {
+ $x = $bw;
+ $y += $h;
+ $row++;
+ }
+ }
+ $s->ResizeWindow($w,$h) if ($why & 1);
+ }
+ $row++ if ($x > $bw);
+ if (defined $m->{Prev} && $m->{Prev} > $m->{Start})
+ {
+ @posn = reverse(@posn);
+ }
+ while (@posn)
+ {
+ my $posn = shift(@posn);
+ my ($s,$x,$y) = (@$posn);
+ $s->MoveWindow($x,$y);
+ $s->MapWindow;
+ }
+ $m->{Prev} = $m->{Start};
+ $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need) if $need;
+}
+
+sub QueueLayout
+{
+ my ($m,$why) = @_;
+ $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
+ $m->{LayoutPending} |= $why;
+}
+
+sub SlaveGeometryRequest
+{
+ my ($m,$s) = @_;
+ my $sw = $s->ReqWidth;
+ my $sh = $s->ReqHeight;
+ my $sz = 0;
+ if ($sw > $m->{Sw})
+ {
+ $m->{Sw} = $sw;
+ $m->QueueLayout(1);
+ $sz++;
+ }
+ if ($sh > $m->{Sh})
+ {
+ $m->{Sh} = $sh;
+ $m->QueueLayout(1);
+ $sz++;
+ }
+ $m->change_size if ($sz);
+}
+
+sub LostSlave
+{
+ my ($m,$s) = @_;
+ @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}});
+ $m->QueueLayout(2);
+}
+
+sub Manage
+{
+ my $m = shift;
+ my $s;
+ foreach $s (@_)
+ {
+ $m->ManageGeometry($s);
+ push(@{$m->{Slaves}},$s);
+ $m->SlaveGeometryRequest($s);
+ }
+ $m->QueueLayout(2 | 1);
+}
+
+sub moveto
+ {
+ my ($m,$frac) = (@_);
+ $m->{Start} = int($m->{Need} * $frac);
+ $m->QueueLayout(4);
+ }
+
+sub scroll
+ {
+ my ($m,$delta,$type) = @_;
+ $delta *= $m->{Rows}/2 if ($type eq 'pages');
+ $m->{Start} += $delta;
+ $m->QueueLayout(4);
+ }
+
+sub yview { my $w = shift; my $c = shift; $w->$c(@_) }
+
+sub FocusIn
+{
+ my ($w) = @_;
+# print 'Focus ',$w->PathName,"\n";
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Configure>',['QueueLayout',8]);
+ $mw->bind($class,'<FocusIn>', 'NoOp');
+ $mw->YscrollBind($class);
+ return $class;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm b/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm
new file mode 100644
index 00000000000..2dd238095f3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TixGrid.pm
@@ -0,0 +1,1597 @@
+
+# TODO:
+#
+# o How to get into state 's0' 'b0' so cursor keys start
+# working (compare with Tk/Widget XYscrollBind
+# o the options -browsecmd and -command callback are not
+# not implemented (as in Tix)
+# o privateData 'state' used only once (check again Grid.tcl)
+# o FloatEntry 'sometimes not activeted immediately on selection
+# o check also Leave Binding. Looks like entry does get unpost'ed
+
+package Tk::TixGrid;
+
+BEGIN
+ {
+ use vars '$DEBUG';
+ $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'ach') ? 1 : 0;
+ print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
+ }
+
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw(Ev $XS_VERSION);
+use Tk::Widget;
+use Carp;
+
+# carp "\n".__PACKAGE__.' is deprecated' unless defined($Test::ntest);
+
+use base 'Tk::Widget';
+
+Construct Tk::Widget 'TixGrid';
+
+bootstrap Tk::TixGrid;
+
+sub Tk_cmd { \&Tk::tixGrid }
+
+sub Tk::Widget::SrclTixGrid { shift->Scrolled('TixGrid' => @_) }
+
+Tk::Methods qw(anchor bdtype delete entrycget entryconfigure format index
+ move set size unset xview yview
+ dragsite dropsite geometryinfo info
+ nearest see selection sort );
+
+use Tk::Submethods
+ (
+ 'anchor' => [ qw(get set) ],
+ 'delete' => [ qw(column row) ],
+ 'info' => [ qw(bbox exists anchor) ],
+ 'move' => [ qw(column row) ],
+ 'selection' => [ qw(adjust clear includes set) ],
+ 'size' => [ qw(column row) ],
+ 'format' => [ qw(grid border) ],
+ );
+
+# edit subcommand is special. It justs invokes tcl code:
+#
+# edit set x y -> tixGrid:EditCell $w, x, y
+# edit apply -> tixGrid:EditApply
+
+# xxx Create an edit sub?
+# sub edit { .... }
+
+sub editSet
+ {
+ die "wrong args. Should be \$w->editSet(x,y)\n" unless @_ == 3;
+ my ($w, $x, $y) = @_;
+ $w->EditCell($x, $y);
+ }
+
+sub editApply
+ {
+ die "wrong args. Should be \$w->editApply()\n" unless @_ == 1;
+ my ($w) = @_;
+ $w->EditApply()
+ }
+
+
+####################################################
+##
+## For button 2 scrolling. So TixGrid has 'standard'
+## standard scrolling interface
+##
+
+#sub scanMark
+# {
+# die "wrong # args: \$w->scanMark(x,y)\n" unless @_ == 3;
+# my ($w) = @_;
+# $w->{__scanMarkXY__} = [ @_[1,2] ];
+# return "";
+# }
+#
+#sub scanDragto
+# {
+# die "wrong # args: \$w->scanDragto(x,y)\n" unless @_ == 3;
+# my ($w, $x, $y) = @_;
+# my ($ox, $oy) = @{ $w->{__scanMarkXY__} };
+#
+# #...
+#
+# return "";
+# }
+
+### end button 2 scrolling stuff ####################
+
+
+# Grid.tcl --
+#
+# This file defines the default bindings for Tix Grid widgets.
+#
+# Copyright (c) 1996, Expert Interface Technologies
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Bindings translated to perl/Tk by Achim Bohnet <ach@mpe.mpg.de>
+
+sub ClassInit
+ {
+ my ($class, $mw) = @_;
+ $class->SUPER::ClassInit($mw);
+
+ $mw->XYscrollBind($class);
+
+ ##
+ ## Button bindings
+ ##
+
+ $mw->bind($class, '<ButtonPress-1>', ['Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Shift-ButtonPress-1>', ['Shift_Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Control-ButtonPress-1>',['Control_Button_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<ButtonRelease-1>', ['ButtonRelease_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<B1-Motion>','Button_Motion');
+ $mw->bind($class, '<Control-B1-Motion>','Control_Button_Motion');
+ $mw->bind($class, '<B1-Leave>','Button_Leave');
+ $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<B1-Enter>', ['B1_Enter', Ev('x'), Ev('y')]);
+ $mw->bind($class, '<Control-B1-Leave>','Control_Button_Leave');
+ $mw->bind($class, '<Control-B1-Enter>', ['Control_B1_Enter', Ev('x'), Ev('y')]);
+
+ ##
+ ## Keyboard bindings
+ ##
+
+ $mw->bind($class, '<Up>', ['DirKey', 'up' ]);
+ $mw->bind($class, '<Down>', ['DirKey', 'down' ]);
+ $mw->bind($class, '<Left>', ['DirKey', 'left' ]);
+ $mw->bind($class, '<Right>', ['DirKey', 'right' ]);
+
+ $mw->PriorNextBind($class);
+
+ $mw->bind($class, '<Return>', 'Return');
+ $mw->bind($class, '<space>', 'Space' );
+
+ return $class;
+ }
+
+#----------------------------------------------------------------------
+#
+#
+# Mouse bindings
+#
+#
+#----------------------------------------------------------------------
+
+sub Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+ $w->ChgState(@_,
+ [
+ '0'=>'1',
+ ]
+ );
+ }
+
+sub Shift_Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+
+# $w->ChgState(@_,
+# [
+# ]
+# );
+ }
+
+sub Control_Button_1
+ {
+ my $w = shift;
+
+ return if $w->cget('-state') eq 'disabled';
+ $w->SetFocus;
+
+ $w->ChgState(@_,
+ [
+ 's0' => 's1',
+ 'b0' => 'b1',
+ 'm0' => 'm1',
+ 'e0' => 'e10',
+ ]
+ );
+ }
+
+sub ButtonRelease_1
+ {
+ shift->ChgState(@_,
+ [
+ '2' => '5',
+ '4' => '3',
+ ]
+ );
+ }
+
+sub B1_Motion
+ {
+ shift->ChgState(@_,
+ [
+ '2' => '4',
+ '4' => '4',
+ ]
+ );
+ }
+
+
+sub Control_B1_Motion
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's4',
+ 's4' => 's4',
+ 'b2' => 'b4',
+ 'b4' => 'b4',
+ 'm2' => 'm4',
+ 'm5' => 'm4',
+ ]
+ );
+ }
+
+
+sub Double_1
+ {
+ shift->ChgState(@_,
+ [
+ 's0' => 's7',
+ 'b0' => 'b7',
+ ]
+ );
+ }
+
+
+sub B1_Leave
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's5',
+ 's4' => 's5',
+ 'b2' => 'b5',
+ 'b4' => 'b5',
+ 'm2' => 'm8',
+ 'm5' => 'm8',
+ 'e2' => 'e8',
+ 'e5' => 'e8',
+ ]
+ );
+ }
+
+
+sub B1_Enter
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's4',
+ 's6' => 's4',
+ 'b5' => 'b4',
+ 'b6' => 'b4',
+ 'm8' => 'm4',
+ 'm9' => 'm4',
+ 'e8' => 'e4',
+ 'e9' => 'e4',
+ ]
+ );
+ }
+
+
+sub Control_B1_Leave
+ {
+ shift->ChgState(@_,
+ [
+ 's2' => 's5',
+ 's4' => 's5',
+ 'b2' => 'b5',
+ 'b4' => 'b5',
+ 'm2' => 'm8',
+ 'm5' => 'm8',
+ ]
+ );
+ }
+
+
+sub Control_B1_Enter
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's4',
+ 's6' => 's4',
+ 'b5' => 'b4',
+ 'b6' => 'b4',
+ 'm8' => 'm4',
+ 'm9' => 'm4',
+ ]
+ );
+ }
+
+
+sub AutoScan
+ {
+ shift->ChgState(@_,
+ [
+ 's5' => 's9',
+ 's6' => 's9',
+ 'b5' => 'b9',
+ 'b6' => 'b9',
+ 'm8' => 'm9',
+ 'm9' => 'm9',
+ 'e8' => 'm9',
+ 'e9' => 'm9',
+ ]
+ );
+ }
+
+#----------------------------------------------------------------------
+#
+#
+# Key bindings
+#
+#
+#----------------------------------------------------------------------
+
+sub DirKey
+ {
+ my ($w, $key) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+print STDERR "$w->DirKey($key)\n" if $DEBUG;
+ $w->ChgState($key,
+ [
+ 's0' => 's8',
+ 'b0' => 'b8',
+ ]
+ );
+ }
+
+
+sub Return
+ {
+ my ($w) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+ $w->ChgState(
+ [
+ 's0' => 's9',
+ 'b0' => 'b9',
+ ]
+ );
+ }
+
+
+sub Space
+ {
+ my ($w) = @_;
+
+ return if $w->cget('-state') eq 'disabled';
+
+ $w->ChgState(
+ [
+ 's0' => 's10',
+ 'b0' => 'b10',
+ ]
+ );
+ }
+
+
+#----------------------------------------------------------------------
+#
+# STATE MANIPULATION
+#
+#
+#----------------------------------------------------------------------
+
+sub GetState
+ {
+ my ($w) = @_;
+ my $data = $w->privateData();
+ $data->{state} = 0 unless exists $data->{state};
+ return $data->{state};
+}
+
+sub Button_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->B1_Motion($Tk::x, $Tk::y);
+}
+
+
+sub Control_Button_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->Control_B1_Motion($Tk::x, $Tk::y);
+}
+
+
+sub Button_Leave
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->B1_Leave();
+}
+
+
+sub Control_Button_Leave
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::X = $Ev->X;
+ $Tk::Y = $Ev->Y;
+ $w->Control_B1_Leave();
+}
+
+
+sub SetState
+ {
+ my ($w, $state) = @_;
+ $w->privateData()->{state} = $state;
+ }
+
+sub GoState
+ {
+ my ($w, $state) = (shift, shift);
+ print STDERR 'Gostate: ', $w->GetState, " --> $state, " if $DEBUG;
+ $w->SetState($state);
+ my $method = "GoState_$state";
+
+ print STDERR 'args=(', join(',',@_), ')'.
+ "\t(",$w->cget('-selectmode').
+ ',',$w->cget('-selectunit').")\n" if $DEBUG;
+
+ if (0)
+ {
+ $@ = '';
+ %@ = (); # Workaround to prevent spurious loss of $@
+ eval { $w->$method(@_) };
+ print STDERR "Error Gostate: '$state': ", $@ if $@;
+ return undef;
+ }
+
+ $w->$method(@_);
+ return undef
+ }
+
+##
+## ChgState is a fancy case statement
+##
+
+sub ChgState
+ {
+ my $w = shift;
+ my $map = pop;
+ print STDERR 'ChgState(', join(',',@_,'['), join(',',@$map,),']) ' if $DEBUG;
+ my $state = $w->GetState;
+
+ my ($match, $to);
+ while (@$map)
+ {
+ $match = shift @$map;
+ $to = shift @$map;
+ if ($match eq $state)
+ {
+ print STDERR "$state --> $to \n" if $DEBUG;
+ $w->GoState($to, @_);
+ return;
+ }
+ }
+ print STDERR "*no* chg for $state\n" if $DEBUG;
+ }
+
+
+#----------------------------------------------------------------------
+# SELECTION ROUTINES
+#----------------------------------------------------------------------
+
+#proc tixGrid:SelectSingle {w ent} {
+# $w selection set [lindex $ent 0] [lindex $ent 1]
+# tixGrid:CallBrowseCmd $w $ent
+#}
+
+sub SelectSingle
+ {
+ my ($w, $n1, $n2) = @_;
+ $w->selection('set', $n1, $n2);
+ $w->Callback('-browsecmd' => $n1, $n2);
+ }
+
+#----------------------------------------------------------------------
+# SINGLE SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_0
+ {
+ my ($w) = @_;
+ my $list = $w->privateData()->{list};
+ return unless defined $list;
+
+ foreach my $cmd (@$list)
+ {
+ # XXX should do more something like $w->Callback'('__pending_cmds__');
+ eval $cmd; # XXX why in tcl in global context (binding?)
+ }
+ undef(@$list); # XXX should really delete? Maybe on needed in TCL
+ }
+
+# XXXX how to translate global context
+# what does unset
+#proc tixGrid:GoState-0 {w} {
+# set list $w:_list
+# global $list
+#
+# if [info exists $list] {
+# foreach cmd [set $list] {
+# uplevel #0 $cmd
+# }
+# if [info exists $list] {
+# unset $list
+# }
+# }
+#}
+
+sub GoState_1
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SetAnchor(@ent);
+ }
+ $w->CheckEdit;
+ $w->selection('clear', 0, 0, 'max', 'max');
+
+ if ($w->cget('-selectmode') ne 'single')
+ {
+ $w->SelectSingle(@ent);
+ }
+ $w->GoState(2);
+ }
+
+sub GoState_2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_3
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SelectSingle(@ent);
+ }
+ $w->GoState(0);
+
+ }
+
+sub GoState_4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x,$y);
+ my $mode = $w->cget('-selectmode');
+
+ if ($mode eq 'single')
+ {
+ $w->SetAnchor(@ent);
+ }
+ elsif ($mode eq 'browse')
+ {
+ $w->SetAnchor(@ent);
+ $w->selection('clear', 0, 0, 'max', 'max');
+ $w->SelectSingle(@ent);
+ }
+ elsif ($mode eq 'multiple' ||
+ $mode eq 'extended')
+ {
+ my (@anchor) = $w->anchor('get');
+ $w->selection('adjust', @anchor[0,1], @ent[0,1]);
+ }
+ }
+
+sub GoState_5
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->SelectSingle(@ent);
+ $w->SetEdit(@ent);
+ }
+ $w->GoState(0);
+
+ }
+
+##############################################
+# BUG xxx
+# return scalar instead of errors
+
+sub mynearest { shift->split_s2a('nearest', @_); }
+sub myanchorGet { shift->split_s2a('anchor', 'get', @_); }
+
+sub split_s2a
+ {
+ my $w = shift;
+ my $method = shift;
+ my @ent = $w->$method(@_);
+ if (@ent == 1)
+ {
+my $tmp = $ent[0];
+ @ent = split(/ /, $ent[0]) if @ent == 1;
+print STDERR join('|',"$method splitted '$tmp' =>",@ent,"\n") if $DEBUG;
+ }
+ else
+ {
+#print STDERR join("|","$method splitted is okay :",@ent,"\n") if $DEBUG;
+ }
+ return @ent;
+ }
+
+##############################################
+
+
+sub GoState_s5
+ {
+ shift->StartScan();
+ }
+
+
+sub GoState_s6
+ {
+ shift->DoScan();
+ }
+
+
+sub GoState_s7
+ {
+ my ($w, $x, $y) = @_;
+
+ my @ent = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('s0');
+ }
+
+
+sub GoState_s8
+ {
+ my ($w, $key) = @_;
+
+ ## BUGS ....
+ ## - anchor is bad, only bbox, exists8
+ ## - looks like anchor is 1-dim: set anchor 0
+ ## - method see unknown (even when defined with Tk::Method)
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = ();
+ }
+ else
+ {
+ @anchor = $w->info($key, @anchor);
+ }
+
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+
+ $w->GoState('s0');
+ }
+
+#proc tixGrid:GoState-s8 {w key} {
+# set anchor [$w info anchor]
+#
+# if {$anchor == ""} {
+# set anchor 0
+# } else {
+# set anchor [$w info $key $anchor]
+# }
+#
+# $w anchor set $anchor
+# $w see $anchor
+# tixGrid:GoState s0 $w
+#}
+
+
+sub GoState_s9
+ {
+ my ($w, $key) = @_;
+
+#print STDERR "GoState_s9 is not implemented\n";
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = ();
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ unless ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-command' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('s0');
+ }
+
+
+sub GoState_s10
+ {
+ my ($w, $key) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = ();
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ unless ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-browsecmd' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('s0');
+ }
+
+
+#----------------------------------------------------------------------
+# BROWSE SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_b0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_b1
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('b2');
+ }
+
+sub GoState_b2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_b3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ }
+
+
+sub GoState_b5 { shift->StartScan(); }
+
+
+sub GoState_b6 { shift->DoScan(); }
+
+
+sub GoState_b7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b8
+ {
+ my ($w, $key) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ if (@anchor)
+ {
+ @anchor = $w->info('key', @anchor);
+ }
+ else
+ {
+ @anchor = (0,0); # ?????
+ }
+
+ $w->anchor('set', @anchor);
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ $w->see(@anchor);
+
+ $w->Callback('-browsecmd' => @anchor);
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b9
+ {
+ my ($w) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = (0,0);
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ if ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-command' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('b0');
+ }
+
+
+sub GoState_b10
+ {
+ my ($w) = @_;
+
+ my (@anchor) = $w->info('anchor');
+ unless (@anchor)
+ {
+ @anchor = (0,0);
+ $w->anchor('set', @anchor);
+ $w->see(@anchor);
+ }
+
+ if ($w->info('anchor'))
+ {
+ # ! may not have any elements
+ #
+ $w->Callback('-browsecmd' => $w->info('anchor'));
+ $w->selection('clear');
+ $w->selection('set', @anchor);
+ }
+
+ $w->GoState('b0');
+ }
+
+#----------------------------------------------------------------------
+# MULTIPLE SELECTION
+#----------------------------------------------------------------------
+
+
+sub GoState_m0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m1
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x,$y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('m2');
+ }
+
+sub GoState_m2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+
+ $w->GoState('m0');
+ }
+
+
+sub GoState_m4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('m5');
+ }
+
+sub GoState_m5
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_m6
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('m0');
+ }
+
+sub GoState_m7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ unless (@from)
+ {
+ @from = @to;
+ $w->anchor('set', @from);
+ }
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('m5');
+ }
+
+
+sub GoState_m8 { shift->StartScan() }
+
+
+sub GoState_m9 { shift->DoScan() }
+
+
+sub GoState_xm7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('m0');
+ }
+
+#----------------------------------------------------------------------
+# EXTENDED SELECTION
+#----------------------------------------------------------------------
+
+sub GoState_e0
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e1
+ {
+ my ($w, $x, $y) = @_;
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e2');
+ }
+
+
+sub GoState_e2
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e3
+ {
+ my ($w) = @_;
+
+ my (@ent) = $w->info('anchor');
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+sub GoState_e4
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('e5');
+ }
+
+sub GoState_e5
+ {
+ my ($w) = @_;
+ }
+
+sub GoState_e6
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+sub GoState_e7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@from) = $w->info('anchor');
+ my (@to) = $w->mynearest($x, $y);
+ unless (@from)
+ {
+ @from = @to;
+ $w->anchor('set', @from);
+ }
+ if (@to)
+ {
+ $w->selection('clear');
+ $w->selection('set', @from, @to);
+ $w->Callback('-browsecmd' => @to);
+ }
+ $w->GoState('e5');
+ }
+
+sub GoState_e8 { shift->StartScan(); }
+
+sub GoState_e9 { shift->DoScan(); }
+
+sub GoState_e10
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ if ($w->info('anchor'))
+ {
+ $w->anchor('set', @ent);
+ }
+ if ($w->selection('includes', @ent))
+ {
+ $w->selection('clear', @ent);
+ }
+ else
+ {
+ $w->selection('set', @ent);
+ }
+ $w->Callback('-browsecmd' => @ent);
+ }
+ $w->GoState('e2');
+ }
+
+sub GoState_xe7
+ {
+ my ($w, $x, $y) = @_;
+
+ my (@ent) = $w->mynearest($x, $y);
+ if (@ent)
+ {
+ $w->selection('clear');
+ $w->selection('set', @ent);
+ $w->Callback('-command' => @ent);
+ }
+ $w->GoState('e0');
+ }
+
+
+#----------------------------------------------------------------------
+# HODGE PODGE
+#----------------------------------------------------------------------
+
+sub GoState_12
+ {
+ my ($w, $x, $y) = @_;
+
+ $w->CancelRepeat; # xxx will not work
+ $w->GoState(5, $x, $y);
+ }
+#proc tixGrid:GoState-12 {w x y} {
+# tkCancelRepeat
+# tixGrid:GoState 5 $w $x $y
+#}
+
+sub GoState_13
+ {
+ # FIX: a) $ent or @ent, b) 13 is never called!!? same in Grid.tcl
+ my ($w, @ent, @oldEnt) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ $data->{indicator} = \@ent;
+ $data->{oldEntry} = \@oldEnt;
+ $w->IndicatorCmd('<Arm>', @ent);
+ }
+# set tkPriv(tix,oldEnt) $oldEnt
+# tixGrid:IndicatorCmd $w <Arm> $ent
+#}
+
+sub GoState_14
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ if ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->anchor('set', @{ $data->{indicator} });
+ $w->selection('clear');
+ $w->selection('set', @{ $data->{indicator} });
+ $w->IndicatorCmd('<Activate>', @{ $data->{indicator} });
+ }
+ else
+ {
+ $w->IndicatorCmd('<Disarm>', @{ $data->{indicator} });
+ }
+ delete($data->{indicator});
+ $w->GoState(0);
+ }
+
+sub GoState_16
+ {
+ my ($w, @ent) = @_;
+
+ return unless (@ent);
+ if ($w->cget('-selectmode') ne 'single')
+ {
+ $w->Select(@ent);
+ $w->Browse(@ent);
+ }
+ }
+
+sub GoState_18
+ {
+ my ($w) = @_;
+
+ $w->CancelRepeat; ## xxx
+ $w->GoState(6, $Tk::x, $Tk::y);
+ }
+
+sub GoState_20
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ if ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->IndicatorCmd('<Arm>', $data->{'indicator'});
+ }
+ else
+ {
+ $w->GoState(21, $x, $y);
+ }
+ }
+
+sub GoState_21
+ {
+ my ($w, $x, $y) = @_;
+
+ my $data = $w->MainWindow->privateData('Tix');
+ unless ($w->InsideArmedIndicator($x, $y))
+ {
+ $w->IndicatorCmd('<Disarm>', $data->{'indicator'});
+ }
+ else
+ {
+ $w->GoState(20, $x, $y);
+ }
+ }
+
+sub GoState_22
+ {
+ my ($w) = @_;
+ my $data = $w->MainWindow->privateData('Tix');
+ if (@{ $data->{oldEntry} })
+ {
+ $w->anchor('set', @{ $data->{oldEntry} });
+ }
+ else
+ {
+ $w->anchor('clear');
+ }
+ $w->GoState(0);
+ }
+
+
+#----------------------------------------------------------------------
+# callback actions
+#----------------------------------------------------------------------
+
+sub SetAnchor
+ {
+ my ($w, @ent) = @_;
+
+ if (@ent)
+ {
+ $w->anchor('set', @ent);
+# $w->see(@ent);
+ }
+ }
+
+# xxx check @ent of @$ent
+sub Select
+ {
+ my ($w, @ent) = @_;
+ $w->selection('clear');
+ $w->selection('set', @ent)
+ }
+
+# xxx check new After handling
+sub StartScan
+ {
+ my ($w) = @_;
+ $Tk::afterId = $w->after(50, [AutoScan, $w]);
+ }
+
+sub DoScan
+ {
+ my ($w) = @_;
+ my $x = $Tk::x;
+ my $y = $Tk::y;
+ my $X = $Tk::X;
+ my $Y = $Tk::Y;
+
+ my $out = 0;
+ if ($y >= $w->height)
+ {
+ $w->yview('scroll', 1, 'units');
+ $out = 1;
+ }
+ if ($y < 0)
+ {
+ $w->yview('scroll', -1, 'units');
+ $out = 1;
+ }
+ if ($x >= $w->width)
+ {
+ $w->xview('scroll', 2, 'units');
+ $out = 1;
+ }
+ if ($x < 0)
+ {
+ $w->xview('scroll', -2, 'units');
+ $out = 1;
+ }
+ if ($out)
+ {
+ $Tk::afterId = $w->after(50, ['AutoScan', $w]);
+ }
+ }
+
+
+#proc tixGrid:CallBrowseCmd {w ent} {
+# return
+#
+# set browsecmd [$w cget -browsecmd]
+# if {$browsecmd != ""} {
+# set bind(specs) {%V}
+# set bind(%V) $ent
+#
+# tixEvalCmdBinding $w $browsecmd bind $ent
+# }
+#}
+
+#proc tixGrid:CallCommand {w ent} {
+# set command [$w cget -command]
+# if {$command != ""} {
+# set bind(specs) {%V}
+# set bind(%V) $ent
+#
+# tixEvalCmdBinding $w $command bind $ent
+# }
+#}
+
+# tixGrid:EditCell --
+#
+# This command is called when "$w edit set $x $y" is called. It causes
+# an SetEdit call when the grid's state is 0.
+#
+
+sub EditCell
+ {
+ my ($w, $x, $y) = @_;
+ my $list = $w->privateData()->{'list'};
+ if ($w->GetState == 0)
+ {
+ $w->SetEdit($x, $y); # xxx really correct ? once 2, once 4 args?
+ }
+ else
+ {
+ push(@$list, [ $w, 'SetEdit', $x, $y]);
+ }
+ }
+#proc tixGrid:EditCell {w x y} {
+# set list $w:_list
+# global $list
+#
+# case [tixGrid:GetState $w] {
+# {0} {
+# tixGrid:SetEdit $w [list $x $y]
+# }
+# default {
+# lappend $list [list tixGrid:SetEdit $w [list $x $y]]
+# }
+# }
+#}
+
+
+# tixGrid:EditApply --
+#
+# This command is called when "$w edit apply $x $y" is called. It causes
+# an CheckEdit call when the grid's state is 0.
+#
+
+sub EditApply
+ {
+ my ($w) = @_;
+ my $list = $w->privateData()->{'list'};
+ if ($w->GetState eq 0)
+ {
+ $w->CheckEdit; # xxx really correct ? once 2, once 4 args?
+ }
+ else
+ {
+ push(@$list, $w->CheckEdit);
+ }
+ }
+#proc tixGrid:EditApply {w} {
+# set list $w:_list
+# global $list
+#
+# case [tixGrid:GetState $w] {
+# {0} {
+# tixGrid:CheckEdit $w
+# }
+# default {
+# lappend $list [list tixGrid:CheckEdit $w]
+# }
+# }
+#}
+
+# tixGrid:CheckEdit --
+#
+# This procedure is called when the user sets the focus on a cell.
+# If another cell is being edited, apply the changes of that cell.
+#
+
+sub CheckEdit
+ {
+ my ($w) = @_;
+ my $edit = $w->privateData->{editentry};
+ if (Tk::Exists($edit))
+ {
+ # If it -command is not empty, it is being used for another cell.
+ # Invoke it so that the other cell can be updated.
+ #
+ if (defined $edit->cget('-command'))
+ {
+ $edit->invoke; # xxx no args??
+ }
+ }
+ }
+
+sub SetFocus
+ {
+ my ($w) = @_;
+ if ($w->cget('-takefocus'))
+ {
+$w->focus;
+# # xxx translation of if ![string match $w.* [focus -displayof $w]] {
+# my $hasfocus = $w->focus(-displayof => $w)->pathname;
+# my $pathname = $w->pathname;
+# if ($hasfocus =~ /\Q$pathname\E.*/)
+# {
+# $w->focus
+# }
+ }
+ }
+
+
+# tixGrid:SetEdit --
+#
+# Puts a floatentry on top of an editable entry.
+#
+
+sub SetEdit
+ {
+ my ($w, $px, $py) = @_;
+
+ $w->CheckEdit;
+
+ my $efc = $w->cget('-editnotifycmd');
+ return unless ( defined($efc) && length($efc) );
+
+ unless ($w->Callback('-editnotifycmd' => $px, $py))
+ {
+ print STDERR "editnotifycmd not defined or returned false\n";
+ return;
+ }
+
+ my $oldvalue;
+ if ($w->info('exists', $px, $py))
+ {
+ # if entry doesn't support -text option. Can't edit it.
+ #
+ # If the application wants to force editing of an entry, it could
+ # delete or replace the entry in the editnotifyCmd procedure.
+ #
+ Tk::catch { $oldvalue = $w->entrycget($px, $py, '-text'); };
+ if ($@)
+ {
+ return;
+ }
+ }
+ else
+ {
+ $oldvalue = '';
+ }
+
+ my @bbox = $w->info('bbox', $px, $py);
+
+ my $edit = $w->privateData()->{__EDIT__};
+ unless (Tk::Exists($edit))
+ {
+ require Tk::FloatEntry;
+ $edit = $w->FloatEntry();
+ $w->privateData()->{__EDIT__} = $edit;
+ }
+ $edit->configure(-command=>[\&DoneEdit, $w, $px, $py]);
+ $edit->post(@bbox);
+ $edit->configure(-value=>$oldvalue);
+}
+
+
+sub DoneEdit
+ {
+ my ($w, $x, $y, @args) = @_;
+
+ my $edit = $w->privateData()->{__EDIT__};
+ $edit->configure(-command=>undef);
+ $edit->unpost;
+
+ # FIX xxx
+ # set value [tixEvent value]
+ my $value = $edit->get;
+ if ($w->info('exists', $x, $y))
+ {
+ Tk::catch { $w->entryconfigure($x, $y, -text=>$value) };
+ if ($@)
+ {
+ return
+ }
+ }
+ elsif ( length($value) )
+ {
+ # This needs to be catch'ed because the default itemtype may
+ # not support the -text option
+ #
+ Tk::catch { $w->set($x,$y,-text $value); };
+ if ($@)
+ {
+ return;
+ }
+ }
+ else
+ {
+ return;
+ }
+ $w->Callback('-editdonecmd' => $x, $y);
+ }
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Tk.xbm b/Master/tlpkg/tlperl/lib/Tk/Tk.xbm
new file mode 100644
index 00000000000..136d4793037
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Tk.xbm
@@ -0,0 +1,44 @@
+#define Tk.xbm_width 61
+#define Tk.xbm_height 61
+static unsigned char Tk.xbm_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0xf8, 0x0e, 0x00, 0x00,
+ 0x00, 0xe0, 0x1e, 0x00, 0xbe, 0x3e, 0x00, 0x00, 0x00, 0xfb, 0x1e, 0x00,
+ 0xfe, 0x7f, 0x00, 0x00, 0x80, 0xdf, 0x0f, 0x00, 0xff, 0xbf, 0x00, 0x00,
+ 0x80, 0xe0, 0x3d, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x47, 0x7f, 0x80,
+ 0xff, 0xfd, 0x01, 0x00, 0x00, 0x7f, 0x3e, 0xc0, 0xff, 0xf1, 0x01, 0x00,
+ 0x00, 0x30, 0x7f, 0xf0, 0xfe, 0xb3, 0x03, 0x00, 0x00, 0xf8, 0x3e, 0x7c,
+ 0xff, 0xcf, 0x07, 0x00, 0x00, 0x78, 0x37, 0xfc, 0x7b, 0xc3, 0x07, 0x00,
+ 0x00, 0xfc, 0x3d, 0xfe, 0x3c, 0x25, 0x0e, 0x00, 0x00, 0xfc, 0x3e, 0x5f,
+ 0x18, 0x41, 0x0b, 0x00, 0x00, 0x5c, 0x3f, 0x5f, 0xf0, 0x59, 0x1b, 0x00,
+ 0x00, 0xdc, 0x9f, 0x3f, 0xe8, 0xbe, 0x17, 0x00, 0x00, 0xbc, 0x9f, 0x2f,
+ 0xa8, 0x5b, 0x15, 0x00, 0x00, 0xdc, 0xdf, 0x25, 0x48, 0x7a, 0x34, 0x00,
+ 0x00, 0x7c, 0xce, 0x1f, 0x20, 0x2c, 0x36, 0x00, 0x00, 0x7c, 0xa7, 0x1f,
+ 0xcc, 0x09, 0xf0, 0x00, 0x00, 0xfc, 0xae, 0x1f, 0x49, 0x05, 0xf6, 0x00,
+ 0x00, 0xfc, 0xac, 0x3f, 0xf8, 0x11, 0xf6, 0x00, 0x00, 0xf8, 0x8d, 0x3f,
+ 0x8e, 0x0e, 0xd6, 0x01, 0x00, 0xf8, 0x9c, 0x7e, 0xd7, 0x5b, 0xff, 0x03,
+ 0x00, 0x70, 0x83, 0x5f, 0xcf, 0xfd, 0xbf, 0x01, 0x00, 0xe0, 0xc3, 0x3b,
+ 0xc7, 0xff, 0x3f, 0x03, 0x00, 0xe0, 0xcf, 0xbf, 0xe3, 0xff, 0x97, 0x03,
+ 0x00, 0x80, 0xfb, 0x7f, 0xfb, 0xff, 0x17, 0x01, 0x00, 0x80, 0xef, 0xff,
+ 0xb3, 0x6f, 0x17, 0x03, 0x00, 0x00, 0xff, 0xff, 0xdf, 0x3f, 0x17, 0x03,
+ 0x00, 0x00, 0x88, 0xff, 0xbf, 0x3f, 0x1b, 0x03, 0x00, 0x00, 0x00, 0x7b,
+ 0x3d, 0x1f, 0x9f, 0x01, 0x00, 0x00, 0x80, 0x1f, 0x7f, 0x1f, 0x9e, 0x00,
+ 0x00, 0x00, 0x80, 0x1f, 0x3f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f,
+ 0x1f, 0x0f, 0x1e, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x1f, 0x0e, 0x1e, 0x00,
+ 0x00, 0xfe, 0x81, 0x8f, 0x1f, 0x0f, 0x1c, 0x00, 0x00, 0x98, 0x81, 0xc7,
+ 0x1f, 0x0e, 0x18, 0x00, 0x00, 0x98, 0x01, 0xc7, 0x0f, 0x0a, 0x18, 0x00,
+ 0xfc, 0x98, 0x99, 0xc7, 0x07, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x8d, 0xc7,
+ 0x02, 0x0e, 0x18, 0x00, 0x8c, 0x99, 0x07, 0xc3, 0x03, 0x03, 0x18, 0x00,
+ 0x8c, 0x99, 0x07, 0xc7, 0x01, 0x03, 0x28, 0x00, 0x8c, 0x99, 0x0d, 0x03,
+ 0x03, 0x01, 0x08, 0x00, 0xfc, 0x98, 0x19, 0x03, 0x86, 0x01, 0x18, 0x00,
+ 0x0c, 0x00, 0x00, 0x03, 0xc4, 0x01, 0x10, 0x00, 0x0c, 0x00, 0x00, 0x03,
+ 0x88, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x03, 0x90, 0x00, 0x18, 0x00,
+ 0x00, 0x00, 0x00, 0x01, 0x30, 0x00, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01,
+ 0xf0, 0x01, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, 0xf8, 0x01, 0x18, 0x00,
+ 0x00, 0x00, 0xc0, 0x01, 0x9e, 0x03, 0x04, 0x00, 0x00, 0x00, 0xc0, 0x01,
+ 0xb3, 0x01, 0x04, 0x00, 0x00, 0x00, 0x60, 0x00, 0x00, 0x01, 0x18, 0x00,
+ 0x00, 0x00, 0x60, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0xdc, 0x00,
+ 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x88, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl/lib/Tk/Tk.xpm b/Master/tlpkg/tlperl/lib/Tk/Tk.xpm
new file mode 100644
index 00000000000..7880a637f39
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Tk.xpm
@@ -0,0 +1,41 @@
+/* XPM */
+static char *Tk[] = {
+/* width height num_colors chars_per_pixel */
+" 32 32 2 1",
+/* colors */
+"# c #008080",
+"a c #ff0000",
+/* pixels */
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"##########aaaaaaaa##############",
+"#######aaaaaaaaaaaa#######aa####",
+"#####aaaaaaaaaaaaaa######aaa####",
+"####aaaaaaaaaaaaaaaa####aaaa####",
+"####aaaaaaa######aa####aaaa#####",
+"###aaaa#########aaa###aaaa######",
+"###aaaa#########aa###aaaa#######",
+"######aa#######aa####aaa########",
+"##############aaa###aaaa########",
+"#############aaa###aaaa##aaa####",
+"#############aa####aaa#aaaaa####",
+"############aaa###aaa#aaaaaa####",
+"###########aaa####aa#aa#aaa#####",
+"###########aaa###aa#aa#aaa######",
+"##########aaa####aaaaaaaa#aa####",
+"##########aaa####aaaaaaa##aa####",
+"#########aaaa####aaaaaaaaaa#####",
+"#########aaa#####aa##aaaaa######",
+"#########aaa##########aa########",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################",
+"################################"
+};
diff --git a/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def b/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def
new file mode 100644
index 00000000000..8f60974226e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TkXSUB.def
@@ -0,0 +1,62 @@
+MkXSUB("Tk::bind", XS_Tk_bind, XStoBind, Tk_BindObjCmd)
+MkXSUB("Tk::pack", XS_Tk_pack, XStoAfterSub, Tk_PackObjCmd)
+MkXSUB("Tk::grid", XS_Tk_grid, XStoGrid, Tk_GridObjCmd)
+MkXSUB("Tk::place", XS_Tk_place, XStoAfterSub, Tk_PlaceObjCmd)
+MkXSUB("Tk::form", XS_Tk_form, XStoAfterSub, Tix_FormCmd)
+MkXSUB("Tk::itemstyle", XS_Tk_itemstyle, XStoTclCmd, Tix_ItemStyleCmd)
+MkXSUB("Tk::winfo", XS_Tk_winfo, XStoSubCmd, Tk_WinfoObjCmd)
+MkXSUB("Tk::font", XS_Tk_font, XStoFont, Tk_FontObjCmd)
+MkXSUB("Tk::wm", XS_Tk_wm, XStoAfterSub, Tk_WmObjCmd)
+MkXSUB("Tk::grab", XS_Tk_grab, XStoSubCmd, Tk_GrabObjCmd)
+MkXSUB("Tk::focus", XS_Tk_focus, XStoSubCmd, Tk_FocusObjCmd)
+MkXSUB("Tk::event", XS_Tk_event, XStoEvent, Tk_EventObjCmd)
+MkXSUB("Tk::property", XS_Tk_property, XStoSubCmd, Tk_PropertyCmd)
+MkXSUB("Tk::clipboard", XS_Tk_clipboard, XStoDisplayof, Tk_ClipboardObjCmd)
+MkXSUB("Tk::bell", XS_Tk_bell, XStoDisplayof, Tk_BellObjCmd)
+MkXSUB("Tk::bindtags", XS_Tk_bindtags, XStoTk, Tk_BindtagsObjCmd)
+MkXSUB("Tk::destroy", XS_Tk_destroy, XStoTk, Tk_DestroyObjCmd)
+MkXSUB("Tk::raise", XS_Tk_raise, XStoTk, Tk_RaiseObjCmd)
+MkXSUB("Tk::lower", XS_Tk_lower, XStoTk, Tk_LowerObjCmd)
+MkXSUB("Tk::option", XS_Tk_option, XStoOption, Tk_OptionObjCmd)
+MkXSUB("Tk::image", XS_Tk_image, XStoImage, Tk_ImageObjCmd)
+MkXSUB("Tk::selection", XS_Tk_selection, XStoTk, Tk_SelectionObjCmd)
+
+#if defined(__WIN32__) || defined(MAC_TCL)
+MkXSUB("Tk::tk_chooseColor", XS_Tk_tk_chooseColor, XStoTk, Tk_ChooseColorObjCmd)
+MkXSUB("Tk::tk_chooseDirectory", XS_Tk_tk_chooseDirectory, XStoTk, Tk_ChooseDirectoryObjCmd)
+MkXSUB("Tk::tk_getOpenFile", XS_Tk_tk_getOpenFile, XStoTk, Tk_GetOpenFileObjCmd)
+MkXSUB("Tk::tk_getSaveFile", XS_Tk_tk_getSaveFile, XStoTk, Tk_GetSaveFileObjCmd)
+#endif
+#if defined(__WIN32__)
+MkXSUB("Tk::tk_messageBox", XS_Tk_tk_messageBox, XStoTk, Tk_MessageBoxObjCmd)
+#endif
+
+MkXSUB("Tk::tk", XS_Tk_tk, XStoTclCmd, Tk_TkObjCmd)
+
+#if 0
+MkXSUB("Tk::exit", XS_Tk_exit, XStoNoWindow, Tcl_ExitCmd)
+MkXSUB("Tk::fileevent", XS_Tk_fileevent, XStoNoWindow, Tcl_FileeventCmd)
+#endif
+MkXSUB("Tk::after", XS_Tk_after, XStoNoWindow, Tcl_AfterObjCmd)
+#ifndef WIN32
+MkXSUB("Tk::send", XS_Tk_send, XStoTclCmd, Tk_SendCmd)
+#endif
+
+MkXSUB("Tk::button", XS_Tk_button, XStoTclCmdNull, Tk_ButtonObjCmd)
+MkXSUB("Tk::checkbutton", XS_Tk_checkbutton, XStoTclCmdNull, Tk_CheckbuttonObjCmd)
+MkXSUB("Tk::label", XS_Tk_label, XStoTclCmdNull, Tk_LabelObjCmd)
+MkXSUB("Tk::radiobutton", XS_Tk_radiobutton, XStoTclCmdNull, Tk_RadiobuttonObjCmd)
+MkXSUB("Tk::_menu", XS_Tk__menu, XStoTclCmdNull, 0)
+
+MkXSUB("Tk::message", XS_Tk_message, XStoTclCmd, Tk_MessageObjCmd)
+MkXSUB("Tk::frame", XS_Tk_frame, XStoTclCmd, Tk_FrameObjCmd)
+MkXSUB("Tk::labelframe", XS_Tk_labelframe, XStoTclCmd, Tk_LabelframeObjCmd)
+MkXSUB("Tk::panedwindow", XS_Tk_panedwindow, XStoTclCmd, Tk_PanedWindowObjCmd)
+MkXSUB("Tk::toplevel", XS_Tk_toplevel, XStoTclCmd, Tk_ToplevelObjCmd)
+MkXSUB("Tk::update", XS_Tk_update, XStoTclCmd, Tk_UpdateObjCmd)
+MkXSUB("Tk::tkwait", XS_Tk_tkwait, XStoTclCmd, Tk_TkwaitObjCmd)
+MkXSUB("Tk::configure", XS_Tk_configure, XStoWidget, newSVpv("configure",0))
+MkXSUB("Tk::cget", XS_Tk_cget, XStoWidget, newSVpv("cget",0))
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm b/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm
new file mode 100644
index 00000000000..7bcd156d475
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Toplevel.pm
@@ -0,0 +1,211 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Toplevel;
+use AutoLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $
+
+use base qw(Tk::Wm Tk::Frame);
+
+Construct Tk::Widget 'Toplevel';
+
+sub Tk_cmd { \&Tk::toplevel }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-screen','-use')
+}
+
+sub Populate
+{
+ my ($cw,$arg) = @_;
+ $cw->SUPER::Populate($arg);
+ $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
+}
+
+sub Icon
+{
+ my ($top,%args) = @_;
+ my $icon = $top->iconwindow;
+ my $state = $top->state;
+ if ($state ne 'withdrawn')
+ {
+ $top->withdraw;
+ $top->update; # Let attributes propogate
+ }
+ unless (defined $icon)
+ {
+ $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon');
+ $icon->withdraw;
+ # Fake Populate
+ my $lab = $icon->Component('Label' => 'icon');
+ $lab->pack('-expand'=>1,'-fill' => 'both');
+ $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']);
+ # Now do tail of InitObject
+ $icon->ConfigDefault(\%args);
+ # And configure that new would have done
+ $top->iconwindow($icon);
+ $top->update;
+ $lab->DisableButtonEvents;
+ $lab->update;
+ }
+ $top->iconimage($args{'-image'}) if (exists $args{'-image'});
+ $icon->configure(%args);
+ $icon->idletasks; # Let size request propogate
+ $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight);
+ $icon->update; # Let attributes propogate
+ $top->deiconify if ($state eq 'normal');
+ $top->iconify if ($state eq 'iconic');
+}
+
+sub menu
+{
+ my $w = shift;
+ my $menu;
+ $menu = $w->cget('-menu');
+ unless (defined $menu)
+ {
+ $w->configure(-menu => ($menu = $w->SUPER::menu))
+ }
+ $menu->configure(@_) if @_;
+ return $menu;
+}
+
+
+1;
+__END__
+
+#----------------------------------------------------------------------
+#
+# Focus Group
+#
+# Focus groups are used to handle the user's focusing actions inside a
+# toplevel.
+#
+# One example of using focus groups is: when the user focuses on an
+# entry, the text in the entry is highlighted and the cursor is put to
+# the end of the text. When the user changes focus to another widget,
+# the text in the previously focused entry is validated.
+#
+
+#----------------------------------------------------------------------
+# tkFocusGroup_Create --
+#
+# Create a focus group. All the widgets in a focus group must be
+# within the same focus toplevel. Each toplevel can have only
+# one focus group, which is identified by the name of the
+# toplevel widget.
+#
+sub FG_Create {
+ my $t = shift;
+ unless (exists $t->{'_fg'}) {
+ $t->{'_fg'} = 1;
+ $t->bind('<FocusIn>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_In($w, $Ev->d);
+ }
+ );
+ $t->bind('<FocusOut>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Out($w, $Ev->d);
+ }
+ );
+ $t->bind('<Destroy>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Destroy($w);
+ }
+ );
+ # <Destroy> is not sufficient to break loops if never mapped.
+ $t->OnDestroy([$t,'FG_Destroy']);
+ }
+}
+
+# tkFocusGroup_BindIn --
+#
+# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
+# called when the widget is focused on by the user.
+#
+sub FG_BindIn {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_BindOut --
+#
+# Add a widget into the "FocusOut" list of the focus group. The
+# $cmd will be called when the widget loses the focus (User
+# types Tab or click on another widget).
+#
+sub FG_BindOut {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+sub FG_Destroy {
+ my($t, $w) = @_;
+ if (!defined($w) || $t == $w) {
+ delete $t->{'_fg'};
+ delete $t->{'_focus'};
+ delete $t->{'_FocusOut'};
+ delete $t->{'_FocusIn'};
+ } else {
+ if (exists $t->{'_focus'}) {
+ delete $t->{'_focus'} if ($t->{'_focus'} == $w);
+ }
+ delete $t->{'_FocusIn'}{$w};
+ delete $t->{'_FocusOut'}{$w};
+ }
+}
+
+# tkFocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+sub FG_In {
+ my($t, $w, $detail) = @_;
+ if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
+ # This is already in focus
+ return;
+ } else {
+ $t->{'_focus'} = $w;
+ $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
+ }
+}
+
+# tkFocusGroup_Out --
+#
+# Handles the <FocusOut> event. Checks if this is really a lose
+# focus event, not one generated by the mouse moving out of the
+# toplevel window. Calls the FocusOut command for the widget
+# who loses its focus.
+#
+sub FG_Out {
+ my($t, $w, $detail) = @_;
+ if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
+ # This is caused by mouse moving out of the window
+ return;
+ }
+ unless (exists $t->{'_FocusOut'}{$w}) {
+ return;
+ } else {
+ $t->{'_FocusOut'}{$w}->Call;
+ delete $t->{'_focus'};
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/Trace.pm b/Master/tlpkg/tlperl/lib/Tk/Trace.pm
new file mode 100644
index 00000000000..1e38e79a065
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Trace.pm
@@ -0,0 +1,405 @@
+package Tk::Trace;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Carp;
+use Tie::Watch;
+use strict;
+
+# The %TRACE hash is indexed by stringified variable reference. Each hash
+# bucket contains an array reference having two elements:
+#
+# ->[0] = a reference to the variable's Tie::Watch object
+# ->[1] = a hash reference with these keys: -fetch, -store, -destroy
+# ->{key} = [ active flag, [ callback list ] ]
+# where each callback is a normalized callback array reference
+#
+# Thus, each trace type (r w u ) may have multiple traces.
+
+my %TRACE; # watchpoints indexed by stringified ref
+
+my %OP = ( # trace to Tie::Watch operation map
+ r => '-fetch',
+ w => '-store',
+ u => '-destroy',
+);
+
+sub fetch {
+
+ # fetch() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ # $_[1] = undef for a scalar, an index/key for an array/hash
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = current value
+ # $_[2] = operation 'r'
+ # $_[3 .. $#_] = optional user callback arguments
+ #
+ # The user callback returns the final value to assign the variable.
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Fetch(@_); # get variable's current value
+ my $aref = $self->Args('-fetch'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-fetch}; # active flag/callbacks
+ return $val unless $call->[0]; # if fetch inactive
+
+ my $final_val;
+ foreach my $aref (reverse @$call[ 1 .. $#{@$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ unshift @_, undef if scalar @_ == 0; # undef "index" for a scalar
+ my @args = @_; # save for post-callback work
+ $args[1] = &$sub(@_, $val, 'r', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $final_val = $self->Store(@args); # update variable's value
+ }
+ $final_val;
+
+} # end fetch
+
+sub store {
+
+ # store() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ # $_[1] = new value for a scalar, index/key for an array/hash
+ # $_[2] = undef for a scalar, new value for an array/hash
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = new value
+ # $_[2] = operation 'w'
+ # $_[3 .. $#_] = optional user callback arguments
+ #
+ # The user callback returns the final value to assign the variable.
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Store(@_); # store variable's new value
+ my $aref = $self->Args('-store'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-store}; # active flag/callbacks
+ return $val unless $call->[0]; # if store inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ unshift @_, undef if scalar @_ == 1; # undef "index" for a scalar
+ my @args = @_; # save for post-callback work
+ $args[1] = &$sub(@_, 'w', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $self->Store(@args); # update variable's value
+ }
+
+} # end store
+
+sub destroy {
+
+ # destroy() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = final value
+ # $_[2] = operation 'u'
+ # $_[3 .. $#_] = optional user callback arguments
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Fetch(@_); # variable's final value
+ my $aref = $self->Args('-destroy'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-destroy}; # active flag/callbacks
+ return $val unless $call->[0]; # if destroy inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ my $val = $self->Fetch(@_); # get final value
+ &$sub(undef, $val, 'u', @args_copy); # invoke user callback
+ $self->Destroy(@_); # destroy variable
+ }
+
+} # end destroy
+
+sub Tk::Widget::traceVariable {
+
+ my( $parent, $vref, $op, $callback ) = @_;
+
+ {
+ $^W = 0;
+ croak "Illegal parent '$parent', not a widget" unless ref $parent;
+ croak "Illegal variable '$vref', not a reference" unless ref $vref;
+ croak "Illegal trace operation '$op'" unless $op;
+ croak "Illegal trace operation '$op'" if $op =~ /[^rwu]/;
+ croak "Illegal callback ($callback)" unless $callback;
+ }
+
+ # Need to add our internal callback to user's callback arg list
+ # so we can call ours first, followed by the user's callback and
+ # any user arguments. Trace callbacks are activated as requied.
+
+ my $trace = $TRACE{$vref};
+ if ( not defined $trace ) {
+ my $watch = Tie::Watch->new(
+ -variable => $vref,
+ -fetch => [ \&fetch, $vref ],
+ -store => [ \&store, $vref ],
+ -destroy => [ \&destroy, $vref ],
+ );
+ $trace = $TRACE{$vref} =
+ [$watch,
+ {
+ -fetch => [ 0 ],
+ -store => [ 0 ],
+ -destroy => [ 0 ],
+ }
+ ];
+ }
+
+ $callback = [ $callback ] if ref $callback eq 'CODE';
+
+ foreach my $o (split '', $op) {
+ push @{$trace->[1]->{$OP{$o}}}, $callback;
+ $trace->[1]->{$OP{$o}}->[0] = 1; # activate
+ }
+
+ return $trace; # for peeking
+
+} # end traceVariable
+
+sub Tk::Widget::traceVdelete {
+
+ my ( $parent, $vref, $op_not_honored, $callabck_not_honored ) = @_;
+
+ if ( defined $TRACE{$vref}->[0] ) {
+ $$vref = $TRACE{$vref}->[0]->Fetch;
+ $TRACE{$vref}->[0]->Unwatch;
+ delete $TRACE{$vref};
+ }
+
+} # end traceVdelete
+
+sub Tk::Widget::traceVinfo {
+
+ my ( $parent, $vref ) = @_;
+
+ return ( defined $TRACE{$vref}->[0] ) ? $TRACE{$vref}->[0]->Info : undef;
+
+} # end traceVinfo
+
+=head1 NAME
+
+Tk::Trace - emulate Tcl/Tk B<trace> functions.
+
+=head1 SYNOPSIS
+
+ use Tk::Trace
+
+ $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]);
+ %vinfo = $mw->traceVinfo(\$v);
+ print "Trace info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $mw->traceVdelete(\$v);
+
+=head1 DESCRIPTION
+
+This class module emulates the Tcl/Tk B<trace> family of commands by
+binding subroutines of your devising to Perl variables using simple
+B<Tie::Watch> features.
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments.
+
+User callbacks are passed these arguments:
+
+ $_[0] = undef for a scalar, index/key for array/hash
+ $_[1] = variable's current (read), new (write), final (undef) value
+ $_[2] = operation (r, w, or u)
+ $_[3 .. $#_] = optional user callback arguments
+
+As a Trace user, you have an important responsibility when writing your
+callback, since you control the final value assigned to the variable.
+A typical callback might look like:
+
+ sub callback {
+ my($index, $value, $op, @args) = @_;
+ return if $op eq 'u';
+ # .... code which uses $value ...
+ return $value; # variable's final value
+ }
+
+Note that the callback's return value becomes the variable's final value,
+for either read or write traces.
+
+For write operations, the variable is updated with its new value before
+the callback is invoked.
+
+Multiple read, write and undef callbacks can be attached to a variable,
+which are invoked in reverse order of creation.
+
+=head1 METHODS
+
+=over 4
+
+=item $mw->traceVariable(varRef, op => callback);
+
+B<varRef> is a reference to the scalar, array or hash variable you
+wish to trace. B<op> is the trace operation, and can be any combination
+of B<r> for read, B<w> for write, and B<u> for undef. B<callback> is a
+standard Perl/Tk callback, and is invoked, depending upon the value of
+B<op>, whenever the variable is read, written, or destroyed.
+
+=item %vinfo = $mw->traceVinfo(varRef);
+
+Returns a hash detailing the internals of the Trace object, with these
+keys:
+
+ %vinfo = (
+ -variable => varRef
+ -debug => '0'
+ -shadow => '1'
+ -value => 'HELLO SCALAR'
+ -destroy => callback
+ -fetch => callback
+ -store => callback
+ -legible => above data formatted as a list of string, for printing
+ );
+
+For array and hash Trace objects, the B<-value> key is replaced with a
+B<-ptr> key which is a reference to the parallel array or hash.
+Additionally, for an array or hash, there are key/value pairs for
+all the variable specific callbacks.
+
+=item $mw->traceVdelete(\$v);
+
+Stop tracing the variable.
+
+=back
+
+=head1 EXAMPLES
+
+ # Trace a Scale's variable and move a meter in unison.
+
+ use Tk;
+ use Tk::widgets qw/Trace/;
+
+ $pi = 3.1415926;
+ $mw = MainWindow->new;
+ $c = $mw->Canvas( qw/-width 200 -height 110 -bd 2 -relief sunken/ )->grid;
+ $c->createLine( qw/100 100 10 100 -tag meter -arrow last -width 5/ );
+ $s = $mw->Scale( qw/-orient h -from 0 -to 100 -variable/ => \$v )->grid;
+ $mw->Label( -text => 'Slide Me for 5 Seconds' )->grid;
+
+ $mw->traceVariable( \$v, 'w' => [ \&update_meter, $s ] );
+
+ $mw->after( 5000 => sub {
+ print "Untrace time ...\n";
+ %vinfo = $s->traceVinfo( \$v );
+ print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $c->traceVdelete( \$v );
+ });
+
+ MainLoop;
+
+ sub update_meter {
+ my( $index, $value, $op, @args ) = @_;
+ return if $op eq 'u';
+ $min = $s->cget( -from );
+ $max = $s->cget( -to );
+ $pos = $value / abs( $max - $min );
+ $x = 100.0 - 90.0 * ( cos( $pos * $pi ) );
+ $y = 100.0 - 90.0 * ( sin( $pos * $pi ) );
+ $c->coords( qw/meter 100 100/, $x, $y );
+ return $value;
+ }
+
+ # Predictive text entry.
+
+ use Tk;
+ use Tk::widgets qw/ LabEntry Trace /;
+ use strict;
+
+ my @words = qw/radio television telephone turntable microphone/;
+
+ my $mw = MainWindow->new;
+
+ my $e = $mw->LabEntry(
+ qw/ -label Thing -width 40 /,
+ -labelPack => [ qw/ -side left / ],
+ -textvariable => \my $thing,
+ );
+ my $t = $mw->Text( qw/ -height 10 -width 50 / );;
+
+ $t->pack( $e, qw/ -side top / );
+
+ $e->focus;
+ $e->traceVariable( \$thing, 'w', [ \&trace_thing, $e, $t ] );
+
+ foreach my $k ( 1 .. 12 ) {
+ $e->bind( "<F${k}>" => [ \&ins, $t, Ev('K') ] );
+ }
+ $e->bind( '<Return>' =>
+ sub {
+ print "$thing\n";
+ $_[0]->delete( 0, 'end' );
+ }
+ );
+
+ MainLoop;
+
+ sub trace_thing {
+
+ my( $index, $value, $op, $e, $t ) = @_;
+
+ return unless $value;
+
+ $t->delete( qw/ 1.0 end / );
+ foreach my $w ( @words ) {
+ if ( $w =~ /^$value/ ) {
+ $t->insert( 'end', "$w\n" );
+ }
+ }
+
+ return $value;
+
+ } # end trace_thing
+
+ sub ins {
+
+ my( $e, $t, $K ) = @_;
+
+ my( $index ) = $K =~ /^F(\d+)$/;
+
+ $e->delete( 0, 'end' );
+ $e->insert( 'end', $t->get( "$index.0", "$index.0 lineend" ) );
+ $t->delete( qw/ 1.0 end / );
+
+ } # end ins
+
+=head1 HISTORY
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01
+ . Version 1.0, for Tk800.022.
+
+ sol0@Lehigh.EDU, Lehigh University Computing Center, 2003/09/22
+ . Version 1.1, for Tk804.025, add support for multiple traces of the same
+ type on the same variable.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000 - 2003 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Tree.pm b/Master/tlpkg/tlperl/lib/Tk/Tree.pm
new file mode 100644
index 00000000000..6d4f76b0c63
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Tree.pm
@@ -0,0 +1,228 @@
+package Tk::Tree;
+# Tree -- TixTree widget
+#
+# Derived from Tree.tcl in Tix 4.1
+#
+# Chris Dean <ctdean@cogit.com>
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tixish/Tree.pm#5 $
+
+use Tk ();
+use Tk::Derived;
+use Tk::HList;
+use base qw(Tk::Derived Tk::HList);
+use strict;
+
+Construct Tk::Widget 'Tree';
+
+sub Tk::Widget::ScrlTree { shift->Scrolled('Tree' => @_) }
+
+sub Populate
+{
+ my( $w, $args ) = @_;
+
+ $w->SUPER::Populate( $args );
+
+ $w->ConfigSpecs(
+ -ignoreinvoke => ['PASSIVE', 'ignoreInvoke', 'IgnoreInvoke', 0],
+ -opencmd => ['CALLBACK', 'openCmd', 'OpenCmd', 'OpenCmd' ],
+ -indicatorcmd => ['CALLBACK', 'indicatorCmd', 'IndicatorCmd', 'IndicatorCmd'],
+ -closecmd => ['CALLBACK', 'closeCmd', 'CloseCmd', 'CloseCmd'],
+ -indicator => ['SELF', 'indicator', 'Indicator', 1],
+ -indent => ['SELF', 'indent', 'Indent', 20],
+ -width => ['SELF', 'width', 'Width', 20],
+ -itemtype => ['SELF', 'itemtype', 'Itemtype', 'imagetext'],
+ -foreground => ['SELF'],
+ );
+}
+
+sub autosetmode
+{
+ my( $w ) = @_;
+ $w->setmode();
+}
+
+sub IndicatorCmd
+{
+ my( $w, $ent, $event ) = @_;
+
+ my $mode = $w->getmode( $ent );
+
+ if ( $event eq '<Arm>' )
+ {
+ if ($mode eq 'open' )
+ {
+ $w->_indicator_image( $ent, 'plusarm' );
+ }
+ else
+ {
+ $w->_indicator_image( $ent, 'minusarm' );
+ }
+ }
+ elsif ( $event eq '<Disarm>' )
+ {
+ if ($mode eq 'open' )
+ {
+ $w->_indicator_image( $ent, 'plus' );
+ }
+ else
+ {
+ $w->_indicator_image( $ent, 'minus' );
+ }
+ }
+ elsif( $event eq '<Activate>' )
+ {
+ $w->Activate( $ent, $mode );
+ $w->Callback( -browsecmd => $ent );
+ }
+}
+
+sub close
+{
+ my( $w, $ent ) = @_;
+ my $mode = $w->getmode( $ent );
+ $w->Activate( $ent, $mode ) if( $mode eq 'close' );
+}
+
+sub open
+{
+ my( $w, $ent ) = @_;
+ my $mode = $w->getmode( $ent );
+ $w->Activate( $ent, $mode ) if( $mode eq 'open' );
+}
+
+sub getmode
+{
+ my( $w, $ent ) = @_;
+
+ return( 'none' ) unless $w->indicatorExists( $ent );
+
+ my $img = $w->_indicator_image( $ent );
+ return( 'open' ) if( $img eq 'plus' || $img eq 'plusarm' );
+ return( 'close' );
+}
+
+sub setmode
+{
+ my ($w,$ent,$mode) = @_;
+ unless (defined $mode)
+ {
+ $mode = 'none';
+ my @args;
+ push(@args,$ent) if defined $ent;
+ my @children = $w->infoChildren( @args );
+ if ( @children )
+ {
+ $mode = 'close';
+ foreach my $c (@children)
+ {
+ $mode = 'open' if $w->infoHidden( $c );
+ $w->setmode( $c );
+ }
+ }
+ }
+
+ if (defined $ent)
+ {
+ if ( $mode eq 'open' )
+ {
+ $w->_indicator_image( $ent, 'plus' );
+ }
+ elsif ( $mode eq 'close' )
+ {
+ $w->_indicator_image( $ent, 'minus' );
+ }
+ elsif( $mode eq 'none' )
+ {
+ $w->_indicator_image( $ent, undef );
+ }
+ }
+}
+
+sub Activate
+{
+ my( $w, $ent, $mode ) = @_;
+ if ( $mode eq 'open' )
+ {
+ $w->Callback( -opencmd => $ent );
+ $w->_indicator_image( $ent, 'minus' );
+ }
+ elsif ( $mode eq 'close' )
+ {
+ $w->Callback( -closecmd => $ent );
+ $w->_indicator_image( $ent, 'plus' );
+ }
+ else
+ {
+
+ }
+}
+
+sub OpenCmd
+{
+ my( $w, $ent ) = @_;
+ # The default action
+ foreach my $kid ($w->infoChildren( $ent ))
+ {
+ $w->show( -entry => $kid );
+ }
+}
+
+sub CloseCmd
+{
+ my( $w, $ent ) = @_;
+
+ # The default action
+ foreach my $kid ($w->infoChildren( $ent ))
+ {
+ $w->hide( -entry => $kid );
+ }
+}
+
+sub Command
+{
+ my( $w, $ent ) = @_;
+
+ return if $w->{Configure}{-ignoreInvoke};
+
+ $w->Activate( $ent, $w->getmode( $ent ) ) if $w->indicatorExists( $ent );
+}
+
+sub _indicator_image
+{
+ my( $w, $ent, $image ) = @_;
+ my $data = $w->privateData();
+ if (@_ > 2)
+ {
+ if (defined $image)
+ {
+ $w->indicatorCreate( $ent, -itemtype => 'image' )
+ unless $w->indicatorExists($ent);
+ $data->{$ent} = $image;
+ $w->indicatorConfigure( $ent, -image => $w->Getimage( $image ) );
+ }
+ else
+ {
+ $w->indicatorDelete( $ent ) if $w->indicatorExists( $ent );
+ delete $data->{$ent};
+ }
+ }
+ return $data->{$ent};
+}
+
+1;
+
+__END__
+
+# Copyright (c) 1996, Expert Interface Technologies
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# The file man.macros and some of the macros used by this file are
+# copyrighted: (c) 1990 The Regents of the University of California.
+# (c) 1994-1995 Sun Microsystems, Inc.
+# The license terms of the Tcl/Tk distrobution are in the file
+# license.tcl.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/Widget.pm b/Master/tlpkg/tlperl/lib/Tk/Widget.pm
new file mode 100644
index 00000000000..e94c037e6fe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Widget.pm
@@ -0,0 +1,1510 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Widget;
+use vars qw($VERSION @DefaultMenuLabels);
+$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/;
+
+require Tk;
+use AutoLoader;
+use strict;
+use Carp;
+use base qw(DynaLoader Tk);
+
+# stubs for 'autoloaded' widget classes
+sub Button;
+sub Canvas;
+sub Checkbutton;
+sub Entry;
+sub Frame;
+sub Label;
+sub Labelframe;
+sub Listbox;
+sub Menu;
+sub Menubutton;
+sub Message;
+sub Panedwindow;
+sub Radiobutton;
+sub Scale;
+sub Scrollbar;
+sub Spinbox;
+sub Text;
+sub Toplevel;
+
+sub Pixmap;
+sub Bitmap;
+sub Photo;
+
+sub ScrlListbox;
+sub Optionmenu;
+
+sub import
+{
+ my $package = shift;
+ carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_);
+ my $need;
+ foreach $need (@_)
+ {
+ unless (defined &{$need})
+ {
+ require "Tk/${need}.pm";
+ }
+ croak "Cannot locate $need" unless (defined &{$need});
+ }
+}
+
+@DefaultMenuLabels = qw[~File ~Help];
+
+# Some tidy-ness functions for winfo stuff
+
+sub True { 1 }
+sub False { 0 }
+
+use Tk::Submethods( 'grab' => [qw(current status release -global)],
+ 'focus' => [qw(-force -lastfor)],
+ 'pack' => [qw(configure forget info propagate slaves)],
+ 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
+ 'form' => [qw(check configure forget grid info slaves)],
+ 'event' => [qw(add delete generate info)],
+ 'place' => [qw(configure forget info slaves)],
+ 'wm' => [qw(capture release)],
+ 'font' => [qw(actual configure create delete families measure metrics names subfonts)]
+ );
+
+BEGIN {
+ # FIXME - these don't work in the compiler
+ *IsMenu = \&False;
+ *IsMenubutton = \&False;
+ *configure_self = \&Tk::configure;
+ *cget_self = \&Tk::cget;
+}
+
+
+
+Direct Tk::Submethods (
+ 'winfo' => [qw(cells class colormapfull depth exists
+ geometry height id ismapped manager name parent reqheight
+ reqwidth rootx rooty screen screencells screendepth screenheight
+ screenmmheight screenmmwidth screenvisual screenwidth visual
+ visualsavailable vrootheight viewable vrootwidth vrootx vrooty
+ width x y toplevel children pixels pointerx pointery pointerxy
+ server fpixels rgb )],
+ 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]);
+
+
+sub DESTROY
+{
+ my $w = shift;
+ $w->destroy if ($w->IsWidget);
+}
+
+sub Install
+{
+ # Dynamically loaded widgets add their core commands
+ # to the Tk base class here
+ my ($package,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+sub CreateOptions
+{
+ return ();
+}
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -colormap for Frame),
+ # or which may as well be applied right away
+ # return these as a list of -key => value pairs
+ # Augment same hash with default values for missing mandatory options,
+ # allthough this can be done later in InitObject.
+
+ # Honour -class => if present, we have hacked Tk_ConfigureWidget to
+ # allow -class to be passed to any widget.
+ my @result = ();
+ my $class = delete $args->{'-class'};
+ ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
+ @result = (-class => "\u$class") if (defined $class);
+ foreach my $opt ($package->CreateOptions)
+ {
+ push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt};
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($obj,$args) = @_;
+ # per object initialization, for example populating
+ # with sub-widgets, adding a few object bindings to augment
+ # inherited class bindings, changing binding tags.
+ # Also another chance to mess with %$args before configure...
+}
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
+}
+
+sub new
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $package = shift;
+ my $parent = shift;
+ $package->InitClass($parent);
+ $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
+ my %args = @_;
+ my @args = $package->CreateArgs($parent,\%args);
+ my $cmd = $package->Tk_cmd;
+ my $pname = $parent->PathName;
+ $pname = '' if ($pname eq '.');
+ my $leaf = delete $args{'Name'};
+ if (defined $leaf)
+ {
+ $leaf =~ s/[^a-z0-9_#]+/_/ig;
+ $leaf = lcfirst($leaf);
+ }
+ else
+ {
+ ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
+ }
+ my $lname = $pname . '.' . $leaf;
+ # create a hash indexed by leaf name to speed up
+ # creation of a lot of sub-widgets of the same type
+ # e.g. entries in Table
+ my $nhash = $parent->TkHash('_names_');
+ $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf});
+ while (defined ($parent->Widget($lname)))
+ {
+ $lname = $pname . '.' . $leaf . ++$nhash->{$leaf};
+ }
+ my $obj = eval { &$cmd($parent, $lname, @args) };
+ confess $@ if $@;
+ unless (ref $obj)
+ {
+ die "No value from $cmd $lname" unless defined $obj;
+ warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname;
+ $obj = $parent->Widget($lname = $obj);
+ die "$obj from $lname" unless ref $obj;
+ }
+ bless $obj,$package;
+ $obj->SetBindtags;
+ my $notice = $parent->can('NoticeChild');
+ $parent->$notice($obj,\%args) if $notice;
+ $obj->InitObject(\%args);
+# ASkludge(\%args,1);
+ $obj->configure(%args) if (%args);
+# ASkludge(\%args,0);
+ return $obj;
+}
+
+sub DelegateFor
+{
+ my ($w,$method) = @_;
+ while(exists $w->{'Delegates'})
+ {
+ my $delegate = $w->{'Delegates'};
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
+ last unless (defined $widget);
+ last if $widget == $w;
+ $w = $widget;
+ }
+ return $w;
+}
+
+sub Delegates
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('Delegates');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+ no strict 'refs';
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ # Pre ->isa scheme
+ *{$base.'::Is'.$name} = \&False;
+ *{$class.'::Is'.$name} = \&True;
+
+ # DelegateFor trickyness is to allow Frames and other derived things
+ # to force creation in a delegate e.g. a ScrlText with embeded windows
+ # need those windows to be children of the Text to get clipping right
+ # and not of the Frame which contains the Text and the scrollbars.
+ *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) };
+}
+
+sub IS
+{
+ return (defined $_[1]) && $_[0] == $_[1];
+}
+
+sub _AutoloadTkWidget
+{
+ my ($self,$method) = @_;
+ my $what = "Tk::Widget::$method";
+ unless (defined &$what)
+ {
+ require "Tk/$method.pm";
+ }
+ return $what;
+}
+
+# require UNIVERSAL; don't load .pm use XS code from perl core though
+
+sub AUTOLOAD
+{
+ # Take a copy into a 'my' variable so we can recurse
+ my $what = $Tk::Widget::AUTOLOAD;
+ my $save = $@;
+ my $name;
+ # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n";
+ # Braces used to preserve $1 et al.
+ {
+ my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
+ confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/;
+ $pkg =~ s#::#/#g;
+ if (defined($name=$INC{"$pkg.pm"}))
+ {
+ $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+ }
+ else
+ {
+ $name = "auto/$what.al";
+ $name =~ s#::#/#g;
+ }
+ }
+ # This may fail, catch error and prevent user's __DIE__ handler
+ # from triggering as well...
+ eval {local $SIG{'__DIE__'}; require $name};
+ if ($@)
+ {
+ croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/);
+ my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
+ if (ref $_[0] && !$_[0]->can($method)
+ && $_[0]->can('Delegate')
+ && $method !~ /^(ConfigSpecs|Delegates)/ )
+ {
+ my $delegate = $_[0]->Delegates;
+ if (%$delegate || tied %$delegate)
+ {
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
+ if (defined $subwidget)
+ {
+ no strict 'refs';
+ # print "AUTOLOAD: $what\n";
+ *{$what} = sub { shift->Delegate($method,@_) };
+ }
+ else
+ {
+ croak "No delegate subwidget '$widget' for $what";
+ }
+ }
+ }
+ }
+ if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/)
+ {
+ # Use ->can as ->isa is broken in perl5.6.0
+ my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget');
+ if ($sub)
+ {
+ carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method);
+ $what = $_[0]->$sub($method)
+ }
+ }
+ }
+ $@ = $save;
+ $DB::sub = $what; # Tell debugger what is going on...
+ unless (defined &$what)
+ {
+ no strict 'refs';
+ *{$what} = sub { croak("Failed to AUTOLOAD '$what'") };
+ }
+ goto &$what;
+}
+
+sub _Destroyed
+{
+ my $w = shift;
+ my $a = delete $w->{'_Destroy_'};
+ if (ref($a))
+ {
+ while (@$a)
+ {
+ my $ent = pop(@$a);
+ if (ref $ent)
+ {
+ eval {local $SIG{'__DIE__'}; $ent->Call };
+ }
+ else
+ {
+ delete $w->{$ent};
+ }
+ }
+ }
+}
+
+sub _OnDestroy
+{
+ my $w = shift;
+ $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
+ push(@{$w->{'_Destroy_'}},@_);
+}
+
+sub OnDestroy
+{
+ my $w = shift;
+ $w->_OnDestroy(Tk::Callback->new(@_));
+}
+
+sub TkHash
+{
+ my ($w,$key) = @_;
+ return $w->{$key} if exists $w->{$key};
+ my $hash = $w->{$key} = {};
+ $w->_OnDestroy($key);
+ return $hash;
+}
+
+sub privateData
+{
+ my $w = shift;
+ my $p = shift || caller;
+ $w->{$p} ||= {};
+}
+
+my @image_types;
+my %image_method;
+
+sub ImageMethod
+{
+ shift if (@_ & 1);
+ while (@_)
+ {
+ my ($name,$method) = splice(@_,0,2);
+ push(@image_types,$name);
+ $image_method{$name} = $method;
+ }
+}
+
+sub Getimage
+{
+ my ($w, $name) = @_;
+ my $mw = $w->MainWindow;
+ croak "Usage \$widget->Getimage('name')" unless defined($name);
+ my $images = ($mw->{'__Images__'} ||= {});
+
+ return $images->{$name} if $images->{$name};
+
+ ImageMethod(xpm => 'Pixmap',
+ gif => 'Photo',
+ ppm => 'Photo',
+ xbm => 'Bitmap' ) unless @image_types;
+
+ foreach my $type (@image_types)
+ {
+ my $method = $image_method{$type};
+ my $file = Tk->findINC( "$name.$type" );
+ next unless( $file && $method );
+ my $sub = $w->can($method);
+ unless (defined &$sub)
+ {
+ require Tk::widgets;
+ Tk::widgets->import($method);
+ }
+ $images->{$name} = $w->$method( -file => $file );
+ return $images->{$name};
+ }
+
+ # Try built-in bitmaps
+ $images->{$name} = $w->Pixmap( -id => $name );
+ return $images->{$name};
+}
+
+sub SaveGrabInfo
+{
+ my $w = shift;
+ $Tk::oldGrab = $w->grabCurrent;
+ if (defined $Tk::oldGrab)
+ {
+ $Tk::grabStatus = $Tk::oldGrab->grabStatus;
+ }
+}
+
+sub grabSave
+{
+ my ($w) = @_;
+ my $grab = $w->grabCurrent;
+ return sub {} if (!defined $grab);
+ my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
+ return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } };
+}
+
+sub focusCurrent
+{
+ my ($w) = @_;
+ $w->Tk::focus('-displayof');
+}
+
+sub focusSave
+{
+ my ($w) = @_;
+ my $focus = $w->focusCurrent;
+ return sub {} if (!defined $focus);
+ return sub { eval {local $SIG{'__DIE__'}; $focus->focus } };
+}
+
+# This is supposed to replicate Tk::after behaviour,
+# but does auto-cancel when widget is deleted.
+require Tk::After;
+
+sub afterCancel
+{
+ my ($w,$what) = @_;
+ if (defined $what)
+ {
+ return $what->cancel if ref($what);
+ carp "dubious cancel of $what" if 0 && $^W;
+ $w->Tk::after('cancel' => $what);
+ }
+}
+
+sub afterIdle
+{
+ my $w = shift;
+ return Tk::After->new($w,'idle','once',@_);
+}
+
+sub afterInfo {
+ my ($w, $id) = @_;
+ if (defined $id) {
+ return ($id->[4], $id->[2], $id->[3]);
+ } else {
+ return sort( keys %{$w->{_After_}} );
+ }
+}
+
+sub after
+{
+ my $w = shift;
+ my $t = shift;
+ if (@_)
+ {
+ if ($t ne 'cancel')
+ {
+ require Tk::After;
+ return Tk::After->new($w,$t,'once',@_)
+ }
+ while (@_)
+ {
+ my $what = shift;
+ $w->afterCancel($what);
+ }
+ }
+ else
+ {
+ $w->Tk::after($t);
+ }
+}
+
+sub repeat
+{
+ require Tk::After;
+ my $w = shift;
+ my $t = shift;
+ return Tk::After->new($w,$t,'repeat',@_);
+}
+
+sub FindMenu
+{
+ # default FindMenu is that there is no menu.
+ return undef;
+}
+
+sub XEvent { shift->{'_XEvent_'} }
+
+sub propertyRoot
+{
+ my $w = shift;
+ return $w->property(@_,'root');
+}
+
+# atom, atomname, containing, interps, pathname
+# don't work this way - there is no window arg
+# So we pretend there was an call the C versions from Tk.xs
+
+sub atom { shift->InternAtom(@_) }
+sub atomname { shift->GetAtomName(@_) }
+sub containing { shift->Containing(@_) }
+
+# interps not done yet
+# pathname not done yet
+
+# walk and descendants adapted from Stephen's composite
+# versions as they only use core features they can go here.
+# hierachy is reversed in that descendants calls walk rather
+# than vice versa as this avoids building a list.
+# Walk should possibly be enhanced so allow early termination
+# like '-prune' of find.
+
+sub Walk
+{
+ # Traverse a widget hierarchy while executing a subroutine.
+ my($cw, $proc, @args) = @_;
+ my $subwidget;
+ foreach $subwidget ($cw->children)
+ {
+ $subwidget->Walk($proc,@args);
+ &$proc($subwidget, @args);
+ }
+} # end walk
+
+sub Descendants
+{
+ # Return a list of widgets derived from a parent widget and all its
+ # descendants of a particular class.
+ # If class is not passed returns the entire widget hierarchy.
+
+ my($widget, $class) = @_;
+ my(@widget_tree) = ();
+
+ $widget->Walk(
+ sub { my ($widget,$list,$class) = @_;
+ push(@$list, $widget) if (!defined($class) or $class eq $widget->class);
+ },
+ \@widget_tree, $class
+ );
+ return @widget_tree;
+}
+
+sub Palette
+{
+ my $w = shift->MainWindow;
+ unless (exists $w->{_Palette_})
+ {
+ my %Palette = ();
+ my $c = $w->Checkbutton();
+ my $e = $w->Entry();
+ my $s = $w->Scrollbar();
+ $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ;
+ $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3];
+ $Palette{'background'} = ($c->configure('-background'))[3];
+ $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3];
+ $Palette{'foreground'} = ($c->configure('-foreground'))[3];
+ $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3];
+ $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3];
+ $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3];
+ $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3];
+ $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3];
+ $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3];
+ $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3];
+ $c->destroy;
+ $e->destroy;
+ $s->destroy;
+ $w->{_Palette_} = \%Palette;
+ }
+ return $w->{_Palette_};
+}
+
+# tk_setPalette --
+# Changes the default color scheme for a Tk application by setting
+# default colors in the option database and by modifying all of the
+# color options for existing widgets that have the default value.
+#
+# Arguments:
+# The arguments consist of either a single color name, which
+# will be used as the new background color (all other colors will
+# be computed from this) or an even number of values consisting of
+# option names and values. The name for an option is the one used
+# for the option database, such as activeForeground, not -activeforeground.
+sub setPalette
+{
+ my $w = shift->MainWindow;
+ my %new = (@_ == 1) ? (background => $_[0]) : @_;
+ my $priority = delete($new{'priority'}) || 'widgetDefault';
+
+ # Create an array that has the complete new palette. If some colors
+ # aren't specified, compute them from other colors that are specified.
+
+ die 'must specify a background color' if (!exists $new{background});
+ $new{'foreground'} = 'black' unless (exists $new{foreground});
+ my @bg = $w->rgb($new{'background'});
+ my @fg = $w->rgb($new{'foreground'});
+ my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
+ foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor')
+ {
+ $new{$i} = $new{'foreground'} unless (exists $new{$i});
+ }
+ unless (exists $new{'disabledForeground'})
+ {
+ $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
+ }
+ $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'});
+
+ unless (exists $new{'activeBackground'})
+ {
+ my @light;
+ # Pick a default active background that is lighter than the
+ # normal background. To do this, round each color component
+ # up by 15% or 1/3 of the way to full white, whichever is
+ # greater.
+ foreach my $i (0, 1, 2)
+ {
+ $light[$i] = $bg[$i]/256;
+ my $inc1 = $light[$i]*15/100;
+ my $inc2 = (255-$light[$i])/3;
+ if ($inc1 > $inc2)
+ {
+ $light[$i] += $inc1
+ }
+ else
+ {
+ $light[$i] += $inc2
+ }
+ $light[$i] = 255 if ($light[$i] > 255);
+ }
+ $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light);
+ }
+ $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'});
+ $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'});
+ $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'});
+
+ # Before doing this, make sure that the Tk::Palette variable holds
+ # the default values of all options, so that tkRecolorTree can
+ # be sure to only change options that have their default values.
+ # If the variable exists, then it is already correct (it was created
+ # the last time this procedure was invoked). If the variable
+ # doesn't exist, fill it in using the defaults from a few widgets.
+ my $Palette = $w->Palette;
+
+ # Walk the widget hierarchy, recoloring all existing windows.
+ $w->RecolorTree(\%new);
+ # Change the option database so that future windows will get the
+ # same colors.
+ foreach my $option (keys %new)
+ {
+ $w->option('add',"*$option",$new{$option},$priority);
+ # Save the options in the global variable Tk::Palette, for use the
+ # next time we change the options.
+ $Palette->{$option} = $new{$option};
+ }
+}
+
+# tkRecolorTree --
+# This procedure changes the colors in a window and all of its
+# descendants, according to information provided by the colors
+# argument. It only modifies colors that have their default values
+# as specified by the Tk::Palette variable.
+#
+# Arguments:
+# w - The name of a window. This window and all its
+# descendants are recolored.
+# colors - The name of an array variable in the caller,
+# which contains color information. Each element
+# is named after a widget configuration option, and
+# each value is the value for that option.
+sub RecolorTree
+{
+ my ($w,$colors) = @_;
+ local ($@);
+ my $Palette = $w->Palette;
+ foreach my $dbOption (keys %$colors)
+ {
+ my $option = "-\L$dbOption";
+ my $value;
+ eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
+ if (defined $value)
+ {
+ if ($value eq $Palette->{$dbOption})
+ {
+ $w->configure($option,$colors->{$dbOption});
+ }
+ }
+ }
+ foreach my $child ($w->children)
+ {
+ $child->RecolorTree($colors);
+ }
+}
+# tkDarken --
+# Given a color name, computes a new color value that darkens (or
+# brightens) the given color by a given percent.
+#
+# Arguments:
+# color - Name of starting color.
+# perecent - Integer telling how much to brighten or darken as a
+# percent: 50 means darken by 50%, 110 means brighten
+# by 10%.
+sub Darken
+{
+ my ($w,$color,$percent) = @_;
+ my @l = $w->rgb($color);
+ my $red = $l[0]/256;
+ my $green = $l[1]/256;
+ my $blue = $l[2]/256;
+ $red = int($red*$percent/100);
+ $red = 255 if ($red > 255);
+ $green = int($green*$percent/100);
+ $green = 255 if ($green > 255);
+ $blue = int($blue*$percent/100);
+ $blue = 255 if ($blue > 255);
+ sprintf('#%02x%02x%02x',$red,$green,$blue)
+}
+# tk_bisque --
+# Reset the Tk color palette to the old "bisque" colors.
+#
+# Arguments:
+# None.
+sub bisque
+{
+ shift->setPalette('activeBackground' => '#e6ceb1',
+ 'activeForeground' => 'black',
+ 'background' => '#ffe4c4',
+ 'disabledForeground' => '#b0b0b0',
+ 'foreground' => 'black',
+ 'highlightBackground' => '#ffe4c4',
+ 'highlightColor' => 'black',
+ 'insertBackground' => 'black',
+ 'selectColor' => '#b03060',
+ 'selectBackground' => '#e6ceb1',
+ 'selectForeground' => 'black',
+ 'troughColor' => '#cdb79e'
+ );
+}
+
+sub PrintConfig
+{
+ require Tk::Pretty;
+ my ($w) = (@_);
+ my $c;
+ foreach $c ($w->configure)
+ {
+ print Tk::Pretty::Pretty(@$c),"\n";
+ }
+}
+
+sub BusyRecurse
+{
+ my ($restore,$w,$cursor,$recurse,$top) = @_;
+ my $c = $w->cget('-cursor');
+ my @tags = $w->bindtags;
+ if ($top || defined($c))
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
+ $w->configure(-cursor => $cursor);
+ }
+ else
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) });
+ }
+ $w->bindtags(['Busy',@tags]);
+ if ($recurse)
+ {
+ foreach my $child ($w->children)
+ {
+ BusyRecurse($restore,$child,$cursor,1,0);
+ }
+ }
+ return $restore;
+}
+
+sub Busy
+{
+ my ($w,@args) = @_;
+ return unless $w->viewable;
+ my($sub, %args);
+ for(my $i=0; $i<=$#args; $i++)
+ {
+ if (ref $args[$i] eq 'CODE')
+ {
+ if (defined $sub)
+ {
+ croak "Multiple code definitions not allowed in Tk::Widget::Busy";
+ }
+ $sub = $args[$i];
+ }
+ else
+ {
+ $args{$args[$i]} = $args[$i+1]; $i++;
+ }
+ }
+ my $cursor = delete $args{'-cursor'};
+ my $recurse = delete $args{'-recurse'};
+ $cursor = 'watch' unless defined $cursor;
+ unless (exists $w->{'Busy'})
+ {
+ my @old = ($w->grabSave);
+ my $key;
+ my @config;
+ foreach $key (keys %args)
+ {
+ push(@config,$key => $w->Tk::cget($key));
+ }
+ if (@config)
+ {
+ push(@old, sub { $w->Tk::configure(@config) });
+ $w->Tk::configure(%args);
+ }
+ unless ($w->Tk::bind('Busy'))
+ {
+ $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]);
+ }
+ $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
+ }
+ my $g = $w->grabCurrent;
+ if (defined $g)
+ {
+ # warn "$g has the grab";
+ $g->grabRelease;
+ }
+ $w->update;
+ eval {local $SIG{'__DIE__'}; $w->grab };
+ $w->update;
+ if ($sub)
+ {
+ eval { $sub->() };
+ my $err = $@;
+ $w->Unbusy(-recurse => $recurse);
+ die $err if $err;
+ }
+}
+
+sub _busy
+{
+ my ($w,$f) = @_;
+ $w->bell if $f;
+ $w->break;
+}
+
+sub Unbusy
+{
+ my ($w) = @_;
+ $w->update;
+ $w->grabRelease if Tk::Exists($w);
+ my $old = delete $w->{'Busy'};
+ if (defined $old)
+ {
+ local $SIG{'__DIE__'};
+ eval { &{pop(@$old)} } while (@$old);
+ }
+ $w->update if Tk::Exists($w);
+}
+
+sub waitVisibility
+{
+ my ($w) = shift;
+ $w->tkwait('visibility',$w);
+}
+
+sub waitVariable
+{
+ my ($w) = shift;
+ $w->tkwait('variable',@_);
+}
+
+sub waitWindow
+{
+ my ($w) = shift;
+ $w->tkwait('window',$w);
+}
+
+sub EventWidget
+{
+ my ($w) = @_;
+ return $w->{'_EventWidget_'};
+}
+
+sub Popwidget
+{
+ my ($ew,$method,$w,@args) = @_;
+ $w->{'_EventWidget_'} = $ew;
+ $w->$method(@args);
+}
+
+sub ColorOptions
+{
+ my ($w,$args) = @_;
+ my $opt;
+ $args = {} unless (defined $args);
+ foreach $opt (qw(-foreground -background -disabledforeground
+ -activebackground -activeforeground
+ ))
+ {
+ $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt})
+ }
+ return (wantarray) ? %$args : $args;
+}
+
+sub XscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Right>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
+
+ $mw->bind($class,'<Home>', ['xview','moveto',0]);
+ $mw->bind($class,'<End>', ['xview','moveto',1]);
+ $mw->XMouseWheelBind($class);
+}
+
+sub PriorNextBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']);
+ $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']);
+}
+
+sub XMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']);
+}
+
+sub YMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<4>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<5>', ['yview','scroll',1,'units']);
+}
+
+sub YscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->PriorNextBind($class);
+ $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<Down>', ['yview','scroll',1,'units']);
+ $mw->YMouseWheelBind($class);
+}
+
+sub XYscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->YscrollBind($class);
+ $mw->XscrollBind($class);
+ # <4> and <5> are how mousewheel looks on X
+}
+
+sub MouseWheelBind
+{
+ my($mw,$class) = @_;
+
+ # The MouseWheel will typically only fire on Windows. However, one
+ # could use the "event generate" command to produce MouseWheel
+ # events on other platforms.
+
+ $mw->Tk::bind($class, '<MouseWheel>',
+ [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]);
+
+ if ($Tk::platform eq 'unix')
+ {
+ # Support for mousewheels on Linux/Unix commonly comes through mapping
+ # the wheel to the extended buttons. If you have a mousewheel, find
+ # Linux configuration info at:
+ # http://www.inria.fr/koala/colas/mouse-wheel-scroll/
+ $mw->Tk::bind($class, '<4>',
+ sub { $_[0]->yview('scroll', -3, 'units')
+ unless $Tk::strictMotif;
+ });
+ $mw->Tk::bind($class, '<5>',
+ sub { $_[0]->yview('scroll', 3, 'units')
+ unless $Tk::strictMotif;
+ });
+ }
+}
+
+sub ScrlListbox
+{
+ my $parent = shift;
+ return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
+}
+
+sub AddBindTag
+{
+ my ($w,$tag) = @_;
+ my $t;
+ my @tags = $w->bindtags;
+ foreach $t (@tags)
+ {
+ return if $t eq $tag;
+ }
+ $w->bindtags([@tags,$tag]);
+}
+
+sub Callback
+{
+ my $w = shift;
+ my $name = shift;
+ my $cb = $w->cget($name);
+ if (defined $cb)
+ {
+ return $cb->Call(@_) if (ref $cb);
+ return $w->$cb(@_);
+ }
+ return (wantarray) ? () : undef;
+}
+
+sub packAdjust
+{
+# print 'packAdjust(',join(',',@_),")\n";
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->pack(%args);
+ %args = $w->packInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},
+ -widget => $w, -delay => $delay, -side => $args{'-side'});
+ $adj->packed($w,%args);
+ return $w;
+}
+
+sub gridAdjust
+{
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->grid(%args);
+ %args = $w->gridInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
+ $adj->gridded($w,%args);
+ return $w;
+}
+
+sub place
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
+ {
+ $w->Tk::place(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::place('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub pack
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
+ {
+ # maybe array/scalar context issue with slaves
+ $w->Tk::pack(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::pack('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub grid
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
+ {
+ my $opt = shift;
+ Tk::grid($opt,$w,@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ Tk::grid('configure',$w,@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub form
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
+ {
+ $w->Tk::form(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::form('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub Scrolled
+{
+ my ($parent,$kind,%args) = @_;
+ $kind = 'Pane' if $kind eq 'Frame';
+ # Find args that are Frame create time args
+ my @args = Tk::Frame->CreateArgs($parent,\%args);
+ my $name = delete $args{'Name'};
+ push(@args,'Name' => $name) if (defined $name);
+ my $cw = $parent->Frame(@args);
+ @args = ();
+ # Now remove any args that Frame can handle
+ foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
+ {
+ push(@args,$k,delete($args{$k})) if (exists $args{$k})
+ }
+ # Anything else must be for target widget - pass at widget create time
+ my $w = $cw->$kind(%args);
+ # Now re-set %args to be ones Frame can handle
+ %args = @args;
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
+ '-background' => [$w,'background','Background'],
+ '-foreground' => [$w,'foreground','Foreground'],
+ );
+ $cw->AddScrollbars($w);
+ $cw->Default("\L$kind" => $w);
+ $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
+ $cw->ConfigDefault(\%args);
+ $cw->configure(%args);
+ return $cw;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+}
+
+sub ForwardEvent
+{
+ my $self = shift;
+ my $to = shift;
+ $to->PassEvent($self->XEvent);
+}
+
+# Save / Return abstract event type as in Tix.
+sub EventType
+{
+ my $w = shift;
+ $w->{'_EventType_'} = $_[0] if @_;
+ return $w->{'_EventType_'};
+}
+
+sub PostPopupMenu
+{
+ my ($w, $X, $Y) = @_;
+ if (@_ < 3)
+ {
+ my $e = $w->XEvent;
+ $X = $e->X;
+ $Y = $e->Y;
+ }
+ my $menu = $w->menu;
+ $menu->Post($X,$Y) if defined $menu;
+}
+
+sub FillMenu
+{
+ my ($w,$menu,@labels) = @_;
+ foreach my $lab (@labels)
+ {
+ my $method = $lab.'MenuItems';
+ $method =~ s/~//g;
+ $method =~ s/[\s-]+/_/g;
+ if ($w->can($method))
+ {
+ $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
+ }
+ }
+ return $menu;
+}
+
+sub menu
+{
+ my ($w,$menu) = @_;
+ if (@_ > 1)
+ {
+ $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
+ $w->{'_MENU_'} = $menu;
+ }
+ return unless defined wantarray;
+ unless (exists $w->{'_MENU_'})
+ {
+ $w->_OnDestroy('_MENU_');
+ $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
+ $w->FillMenu($menu,$w->MenuLabels);
+ }
+ return $w->{'_MENU_'};
+}
+
+sub MenuLabels
+{
+ return @DefaultMenuLabels;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]];
+}
+
+sub WmDeleteWindow
+{
+ shift->toplevel->WmDeleteWindow
+}
+
+sub BalloonInfo
+{
+ my ($widget,$balloon,$X,$Y,@opt) = @_;
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$widget);
+ return $info if defined $info;
+ }
+}
+
+sub ConfigSpecs {
+
+ my $w = shift;
+
+ return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure;
+
+}
+
+*GetSelection =
+ ($Tk::platform eq 'unix'
+ ? sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING")
+ };
+ if ($@)
+ {
+ $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ }
+ $txt;
+ }
+ : sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ $txt;
+ }
+ );
+
+1;
+__END__
+
+sub bindDump {
+
+ # Dump lots of good binding information. This pretty-print subroutine
+ # is, essentially, the following code in disguise:
+ #
+ # print "Binding information for $w\n";
+ # foreach my $tag ($w->bindtags) {
+ # printf "\n Binding tag '$tag' has these bindings:\n";
+ # foreach my $binding ($w->bind($tag)) {
+ # printf " $binding\n";
+ # }
+ # }
+
+ my ($w) = @_;
+
+ my (@bindtags) = $w->bindtags;
+ my $digits = length( scalar @bindtags );
+ my ($spc1, $spc2) = ($digits + 33, $digits + 35);
+ my $format1 = "%${digits}d.";
+ my $format2 = ' ' x ($digits + 2);
+ my $n = 0;
+
+ my @out;
+ push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
+
+ foreach my $tag (@bindtags) {
+ my (@bindings) = $w->bind($tag);
+ $n++; # count this bindtag
+
+ if ($#bindings == -1) {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
+ } else {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
+
+ foreach my $binding ( @bindings ) {
+ my $callback = $w->bind($tag, $binding);
+ push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
+
+ if ($callback =~ /SCALAR/) {
+ if (ref $$callback) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
+ }
+ } elsif ($callback =~ /ARRAY/) {
+ if (ref $callback->[0]) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
+ }
+ foreach my $arg (@$callback[1 .. $#{@$callback}]) {
+ if (ref $arg) {
+ push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
+ } else {
+ push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
+ }
+
+ if (ref $arg eq 'Tk::Ev') {
+ if ($arg =~ /SCALAR/) {
+ push @out, sprintf( ": '$$arg'" );
+ } else {
+ push @out, sprintf( ": '%s'", join("' '", @$arg) );
+ }
+ }
+
+ push @out, sprintf( "\n" );
+ } # forend callback arguments
+ } # ifend callback
+
+ } # forend all bindings for one tag
+
+ } # ifend have bindings
+
+ } # forend all tags
+ push @out, sprintf( "\n" );
+ return @out;
+
+} # end bindDump
+
+
+sub ASkludge
+{
+ my ($hash,$sense) = @_;
+ foreach my $key (%$hash)
+ {
+ if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
+ {
+ if ($sense)
+ {
+ my $val = ${$hash->{$key}};
+ require Tie::Scalar;
+ tie ${$hash->{$key}},'Tie::StdScalar';
+ ${$hash->{$key}} = $val;
+ }
+ else
+ {
+ untie ${$hash->{$key}};
+ }
+ }
+ }
+}
+
+
+
+# clipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+#
+# This method is obsolete use clipboardOperations and abstract
+# event types instead. See Clipboard.pm and Mainwindow.pm
+
+sub clipboardKeysyms
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ if (@_)
+ {
+ my $copy = shift;
+ $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy);
+ }
+ if (@_)
+ {
+ my $cut = shift;
+ $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut);
+ }
+ if (@_)
+ {
+ my $paste = shift;
+ $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
+ }
+}
+
+sub pathname
+{
+ my ($w,$id) = @_;
+ my $x = $w->winfo('pathname',-displayof => oct($id));
+ return $x->PathName;
+}
diff --git a/Master/tlpkg/tlperl/lib/Tk/Wm.pm b/Master/tlpkg/tlperl/lib/Tk/Wm.pm
new file mode 100644
index 00000000000..ffbe4877857
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Wm.pm
@@ -0,0 +1,174 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Wm;
+use AutoLoader;
+
+require Tk::Widget;
+*AUTOLOAD = \&Tk::Widget::AUTOLOAD;
+
+use strict qw(vars);
+
+# There are issues with this stuff now we have Tix's wm release/capture
+# as toplevel-ness is now dynamic.
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Submethods;
+
+*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) };
+*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) };
+
+Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command
+ deiconify focusmodel frame geometry group
+ iconbitmap iconify iconimage iconmask iconname
+ iconwindow maxsize minsize overrideredirect positionfrom
+ protocol resizable sizefrom state title transient
+ withdraw wrapper)]);
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,'all']);
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
+ '-popanchor' => ['PASSIVE',undef,undef,undef],
+ '-popover' => ['PASSIVE',undef,undef,undef]
+ );
+}
+
+sub MoveResizeWindow
+{
+ my ($w,$x,$y,$width,$height) = @_;
+ $w->withdraw;
+ $w->geometry($width.'x'.$height);
+ $w->MoveToplevelWindow($x,$y);
+ $w->deiconify;
+}
+
+sub WmDeleteWindow
+{
+ my ($w) = @_;
+ my $cb = $w->protocol('WM_DELETE_WINDOW');
+ if (defined $cb)
+ {
+ $cb->Call;
+ }
+ else
+ {
+ $w->destroy;
+ }
+}
+
+
+1;
+
+__END__
+
+
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/X.pm b/Master/tlpkg/tlperl/lib/Tk/X.pm
new file mode 100644
index 00000000000..06eefbf6bd9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X.pm
@@ -0,0 +1,398 @@
+package Tk::X;
+
+use strict;
+use Carp;
+use vars qw($VERSION @EXPORT $AUTOLOAD);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Xlib/X/X.pm#4 $
+use Tk qw($XS_VERSION);
+
+require Exporter;
+require DynaLoader;
+require AutoLoader;
+
+
+use base qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ Above
+ AllTemporary
+ AllocAll
+ AllocNone
+ AllowExposures
+ AlreadyGrabbed
+ Always
+ AnyButton
+ AnyKey
+ AnyModifier
+ AnyPropertyType
+ ArcChord
+ ArcPieSlice
+ AsyncBoth
+ AsyncKeyboard
+ AsyncPointer
+ AutoRepeatModeDefault
+ AutoRepeatModeOff
+ AutoRepeatModeOn
+ BadAccess
+ BadAlloc
+ BadAtom
+ BadColor
+ BadCursor
+ BadDrawable
+ BadFont
+ BadGC
+ BadIDChoice
+ BadImplementation
+ BadLength
+ BadMatch
+ BadName
+ BadPixmap
+ BadRequest
+ BadValue
+ BadWindow
+ Below
+ BottomIf
+ Button1
+ Button1Mask
+ Button1MotionMask
+ Button2
+ Button2Mask
+ Button2MotionMask
+ Button3
+ Button3Mask
+ Button3MotionMask
+ Button4
+ Button4Mask
+ Button4MotionMask
+ Button5
+ Button5Mask
+ Button5MotionMask
+ ButtonMotionMask
+ ButtonPress
+ ButtonPressMask
+ ButtonRelease
+ ButtonReleaseMask
+ CWBackPixel
+ CWBackPixmap
+ CWBackingPixel
+ CWBackingPlanes
+ CWBackingStore
+ CWBitGravity
+ CWBorderPixel
+ CWBorderPixmap
+ CWBorderWidth
+ CWColormap
+ CWCursor
+ CWDontPropagate
+ CWEventMask
+ CWHeight
+ CWOverrideRedirect
+ CWSaveUnder
+ CWSibling
+ CWStackMode
+ CWWidth
+ CWWinGravity
+ CWX
+ CWY
+ CapButt
+ CapNotLast
+ CapProjecting
+ CapRound
+ CenterGravity
+ CirculateNotify
+ CirculateRequest
+ ClientMessage
+ ClipByChildren
+ ColormapChangeMask
+ ColormapInstalled
+ ColormapNotify
+ ColormapUninstalled
+ Complex
+ ConfigureNotify
+ ConfigureRequest
+ ControlMapIndex
+ ControlMask
+ Convex
+ CoordModeOrigin
+ CoordModePrevious
+ CopyFromParent
+ CreateNotify
+ CurrentTime
+ CursorShape
+ DefaultBlanking
+ DefaultExposures
+ DestroyAll
+ DestroyNotify
+ DirectColor
+ DisableAccess
+ DisableScreenInterval
+ DisableScreenSaver
+ DoBlue
+ DoGreen
+ DoRed
+ DontAllowExposures
+ DontPreferBlanking
+ EastGravity
+ EnableAccess
+ EnterNotify
+ EnterWindowMask
+ EvenOddRule
+ Expose
+ ExposureMask
+ FamilyChaos
+ FamilyDECnet
+ FamilyInternet
+ FillOpaqueStippled
+ FillSolid
+ FillStippled
+ FillTiled
+ FirstExtensionError
+ FocusChangeMask
+ FocusIn
+ FocusOut
+ FontChange
+ FontLeftToRight
+ FontRightToLeft
+ ForgetGravity
+ GCArcMode
+ GCBackground
+ GCCapStyle
+ GCClipMask
+ GCClipXOrigin
+ GCClipYOrigin
+ GCDashList
+ GCDashOffset
+ GCFillRule
+ GCFillStyle
+ GCFont
+ GCForeground
+ GCFunction
+ GCGraphicsExposures
+ GCJoinStyle
+ GCLastBit
+ GCLineStyle
+ GCLineWidth
+ GCPlaneMask
+ GCStipple
+ GCSubwindowMode
+ GCTile
+ GCTileStipXOrigin
+ GCTileStipYOrigin
+ GXand
+ GXandInverted
+ GXandReverse
+ GXclear
+ GXcopy
+ GXcopyInverted
+ GXequiv
+ GXinvert
+ GXnand
+ GXnoop
+ GXnor
+ GXor
+ GXorInverted
+ GXorReverse
+ GXset
+ GXxor
+ GrabFrozen
+ GrabInvalidTime
+ GrabModeAsync
+ GrabModeSync
+ GrabNotViewable
+ GrabSuccess
+ GraphicsExpose
+ GravityNotify
+ GrayScale
+ HostDelete
+ HostInsert
+ IncludeInferiors
+ InputFocus
+ InputOnly
+ InputOutput
+ IsUnmapped
+ IsUnviewable
+ IsViewable
+ JoinBevel
+ JoinMiter
+ JoinRound
+ KBAutoRepeatMode
+ KBBellDuration
+ KBBellPercent
+ KBBellPitch
+ KBKey
+ KBKeyClickPercent
+ KBLed
+ KBLedMode
+ KeyPress
+ KeyPressMask
+ KeyRelease
+ KeyReleaseMask
+ KeymapNotify
+ KeymapStateMask
+ LASTEvent
+ LSBFirst
+ LastExtensionError
+ LeaveNotify
+ LeaveWindowMask
+ LedModeOff
+ LedModeOn
+ LineDoubleDash
+ LineOnOffDash
+ LineSolid
+ LockMapIndex
+ LockMask
+ LowerHighest
+ MSBFirst
+ MapNotify
+ MapRequest
+ MappingBusy
+ MappingFailed
+ MappingKeyboard
+ MappingModifier
+ MappingNotify
+ MappingPointer
+ MappingSuccess
+ Mod1MapIndex
+ Mod1Mask
+ Mod2MapIndex
+ Mod2Mask
+ Mod3MapIndex
+ Mod3Mask
+ Mod4MapIndex
+ Mod4Mask
+ Mod5MapIndex
+ Mod5Mask
+ MotionNotify
+ NoEventMask
+ NoExpose
+ NoSymbol
+ Nonconvex
+ None
+ NorthEastGravity
+ NorthGravity
+ NorthWestGravity
+ NotUseful
+ NotifyAncestor
+ NotifyDetailNone
+ NotifyGrab
+ NotifyHint
+ NotifyInferior
+ NotifyNonlinear
+ NotifyNonlinearVirtual
+ NotifyNormal
+ NotifyPointer
+ NotifyPointerRoot
+ NotifyUngrab
+ NotifyVirtual
+ NotifyWhileGrabbed
+ Opposite
+ OwnerGrabButtonMask
+ ParentRelative
+ PlaceOnBottom
+ PlaceOnTop
+ PointerMotionHintMask
+ PointerMotionMask
+ PointerRoot
+ PointerWindow
+ PreferBlanking
+ PropModeAppend
+ PropModePrepend
+ PropModeReplace
+ PropertyChangeMask
+ PropertyDelete
+ PropertyNewValue
+ PropertyNotify
+ PseudoColor
+ RaiseLowest
+ ReparentNotify
+ ReplayKeyboard
+ ReplayPointer
+ ResizeRedirectMask
+ ResizeRequest
+ RetainPermanent
+ RetainTemporary
+ RevertToNone
+ RevertToParent
+ RevertToPointerRoot
+ ScreenSaverActive
+ ScreenSaverReset
+ SelectionClear
+ SelectionNotify
+ SelectionRequest
+ SetModeDelete
+ SetModeInsert
+ ShiftMapIndex
+ ShiftMask
+ SouthEastGravity
+ SouthGravity
+ SouthWestGravity
+ StaticColor
+ StaticGravity
+ StaticGray
+ StippleShape
+ StructureNotifyMask
+ SubstructureNotifyMask
+ SubstructureRedirectMask
+ Success
+ SyncBoth
+ SyncKeyboard
+ SyncPointer
+ TileShape
+ TopIf
+ TrueColor
+ UnmapGravity
+ UnmapNotify
+ Unsorted
+ VisibilityChangeMask
+ VisibilityFullyObscured
+ VisibilityNotify
+ VisibilityPartiallyObscured
+ VisibilityUnobscured
+ WestGravity
+ WhenMapped
+ WindingRule
+ XYBitmap
+ XYPixmap
+ X_H
+ X_PROTOCOL
+ X_PROTOCOL_REVISION
+ YSorted
+ YXBanded
+ YXSorted
+ ZPixmap
+);
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my $constname;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined X macro $constname";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Tk::X;
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is the stub of documentation for your module. You better edit it!
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/X.h b/Master/tlpkg/tlperl/lib/Tk/X11/X.h
new file mode 100644
index 00000000000..95db07f903f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/X.h
@@ -0,0 +1,677 @@
+/*
+ * $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $
+ */
+
+/* Definitions for the X window system likely to be used by applications */
+
+#ifndef X_H
+#define X_H
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+#define X_PROTOCOL 11 /* current protocol version */
+#define X_PROTOCOL_REVISION 0 /* current minor version */
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# define Cursor XCursor
+# define Region XRegion
+#endif
+
+/* Resources */
+
+#ifdef _WIN64
+typedef __int64 XID;
+#else
+typedef unsigned long XID;
+#endif
+
+typedef XID Window;
+typedef XID Drawable;
+typedef XID Font;
+typedef XID Pixmap;
+typedef XID Cursor;
+typedef XID Colormap;
+typedef XID GContext;
+typedef XID KeySym;
+
+typedef unsigned long Mask;
+
+typedef unsigned long Atom;
+
+typedef unsigned long VisualID;
+
+typedef unsigned long Time;
+
+typedef unsigned long KeyCode; /* In order to use IME, the Macintosh needs
+ * to pack 3 bytes into the keyCode field in
+ * the XEvent. In the real X.h, a KeyCode is
+ * defined as a short, which wouldn't be big
+ * enough. */
+
+/*****************************************************************
+ * RESERVED RESOURCE AND CONSTANT DEFINITIONS
+ *****************************************************************/
+
+#define None 0L /* universal null resource or null atom */
+
+#define ParentRelative 1L /* background pixmap in CreateWindow
+ and ChangeWindowAttributes */
+
+#define CopyFromParent 0L /* border pixmap in CreateWindow
+ and ChangeWindowAttributes
+ special VisualID and special window
+ class passed to CreateWindow */
+
+#define PointerWindow 0L /* destination window in SendEvent */
+#define InputFocus 1L /* destination window in SendEvent */
+
+#define PointerRoot 1L /* focus window in SetInputFocus */
+
+#define AnyPropertyType 0L /* special Atom, passed to GetProperty */
+
+#define AnyKey 0L /* special Key Code, passed to GrabKey */
+
+#define AnyButton 0L /* special Button Code, passed to GrabButton */
+
+#define AllTemporary 0L /* special Resource ID passed to KillClient */
+
+#define CurrentTime 0L /* special Time */
+
+#define NoSymbol 0L /* special KeySym */
+
+/*****************************************************************
+ * EVENT DEFINITIONS
+ *****************************************************************/
+
+/* Input Event Masks. Used as event-mask window attribute and as arguments
+ to Grab requests. Not to be confused with event names. */
+
+#define NoEventMask 0L
+#define KeyPressMask (1L<<0)
+#define KeyReleaseMask (1L<<1)
+#define ButtonPressMask (1L<<2)
+#define ButtonReleaseMask (1L<<3)
+#define EnterWindowMask (1L<<4)
+#define LeaveWindowMask (1L<<5)
+#define PointerMotionMask (1L<<6)
+#define PointerMotionHintMask (1L<<7)
+#define Button1MotionMask (1L<<8)
+#define Button2MotionMask (1L<<9)
+#define Button3MotionMask (1L<<10)
+#define Button4MotionMask (1L<<11)
+#define Button5MotionMask (1L<<12)
+#define ButtonMotionMask (1L<<13)
+#define KeymapStateMask (1L<<14)
+#define ExposureMask (1L<<15)
+#define VisibilityChangeMask (1L<<16)
+#define StructureNotifyMask (1L<<17)
+#define ResizeRedirectMask (1L<<18)
+#define SubstructureNotifyMask (1L<<19)
+#define SubstructureRedirectMask (1L<<20)
+#define FocusChangeMask (1L<<21)
+#define PropertyChangeMask (1L<<22)
+#define ColormapChangeMask (1L<<23)
+#define OwnerGrabButtonMask (1L<<24)
+
+/* Event names. Used in "type" field in XEvent structures. Not to be
+confused with event masks above. They start from 2 because 0 and 1
+are reserved in the protocol for errors and replies. */
+
+#define KeyPress 2
+#define KeyRelease 3
+#define ButtonPress 4
+#define ButtonRelease 5
+#define MotionNotify 6
+#define EnterNotify 7
+#define LeaveNotify 8
+#define FocusIn 9
+#define FocusOut 10
+#define KeymapNotify 11
+#define Expose 12
+#define GraphicsExpose 13
+#define NoExpose 14
+#define VisibilityNotify 15
+#define CreateNotify 16
+#define DestroyNotify 17
+#define UnmapNotify 18
+#define MapNotify 19
+#define MapRequest 20
+#define ReparentNotify 21
+#define ConfigureNotify 22
+#define ConfigureRequest 23
+#define GravityNotify 24
+#define ResizeRequest 25
+#define CirculateNotify 26
+#define CirculateRequest 27
+#define PropertyNotify 28
+#define SelectionClear 29
+#define SelectionRequest 30
+#define SelectionNotify 31
+#define ColormapNotify 32
+#define ClientMessage 33
+#define MappingNotify 34
+#define LASTEvent 35 /* must be bigger than any event # */
+
+
+/* Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer,
+ state in various key-, mouse-, and button-related events. */
+
+#define ShiftMask (1<<0)
+#define LockMask (1<<1)
+#define ControlMask (1<<2)
+#define Mod1Mask (1<<3)
+#define Mod2Mask (1<<4)
+#define Mod3Mask (1<<5)
+#define Mod4Mask (1<<6)
+#define Mod5Mask (1<<7)
+
+/* modifier names. Used to build a SetModifierMapping request or
+ to read a GetModifierMapping request. These correspond to the
+ masks defined above. */
+#define ShiftMapIndex 0
+#define LockMapIndex 1
+#define ControlMapIndex 2
+#define Mod1MapIndex 3
+#define Mod2MapIndex 4
+#define Mod3MapIndex 5
+#define Mod4MapIndex 6
+#define Mod5MapIndex 7
+
+
+/* button masks. Used in same manner as Key masks above. Not to be confused
+ with button names below. */
+
+#define Button1Mask (1<<8)
+#define Button2Mask (1<<9)
+#define Button3Mask (1<<10)
+#define Button4Mask (1<<11)
+#define Button5Mask (1<<12)
+
+#define AnyModifier (1<<15) /* used in GrabButton, GrabKey */
+
+
+/* button names. Used as arguments to GrabButton and as detail in ButtonPress
+ and ButtonRelease events. Not to be confused with button masks above.
+ Note that 0 is already defined above as "AnyButton". */
+
+#define Button1 1
+#define Button2 2
+#define Button3 3
+#define Button4 4
+#define Button5 5
+
+/* Notify modes */
+
+#define NotifyNormal 0
+#define NotifyGrab 1
+#define NotifyUngrab 2
+#define NotifyWhileGrabbed 3
+
+#define NotifyHint 1 /* for MotionNotify events */
+
+/* Notify detail */
+
+#define NotifyAncestor 0
+#define NotifyVirtual 1
+#define NotifyInferior 2
+#define NotifyNonlinear 3
+#define NotifyNonlinearVirtual 4
+#define NotifyPointer 5
+#define NotifyPointerRoot 6
+#define NotifyDetailNone 7
+
+/* Visibility notify */
+
+#define VisibilityUnobscured 0
+#define VisibilityPartiallyObscured 1
+#define VisibilityFullyObscured 2
+
+/* Circulation request */
+
+#define PlaceOnTop 0
+#define PlaceOnBottom 1
+
+/* protocol families */
+
+#define FamilyInternet 0
+#define FamilyDECnet 1
+#define FamilyChaos 2
+
+/* Property notification */
+
+#define PropertyNewValue 0
+#define PropertyDelete 1
+
+/* Color Map notification */
+
+#define ColormapUninstalled 0
+#define ColormapInstalled 1
+
+/* GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes */
+
+#define GrabModeSync 0
+#define GrabModeAsync 1
+
+/* GrabPointer, GrabKeyboard reply status */
+
+#define GrabSuccess 0
+#define AlreadyGrabbed 1
+#define GrabInvalidTime 2
+#define GrabNotViewable 3
+#define GrabFrozen 4
+
+/* AllowEvents modes */
+
+#define AsyncPointer 0
+#define SyncPointer 1
+#define ReplayPointer 2
+#define AsyncKeyboard 3
+#define SyncKeyboard 4
+#define ReplayKeyboard 5
+#define AsyncBoth 6
+#define SyncBoth 7
+
+/* Used in SetInputFocus, GetInputFocus */
+
+#define RevertToNone (int)None
+#define RevertToPointerRoot (int)PointerRoot
+#define RevertToParent 2
+
+/*****************************************************************
+ * ERROR CODES
+ *****************************************************************/
+
+#define Success 0 /* everything's okay */
+#define BadRequest 1 /* bad request code */
+#define BadValue 2 /* int parameter out of range */
+#define BadWindow 3 /* parameter not a Window */
+#define BadPixmap 4 /* parameter not a Pixmap */
+#define BadAtom 5 /* parameter not an Atom */
+#define BadCursor 6 /* parameter not a Cursor */
+#define BadFont 7 /* parameter not a Font */
+#define BadMatch 8 /* parameter mismatch */
+#define BadDrawable 9 /* parameter not a Pixmap or Window */
+#define BadAccess 10 /* depending on context:
+ - key/button already grabbed
+ - attempt to free an illegal
+ cmap entry
+ - attempt to store into a read-only
+ color map entry.
+ - attempt to modify the access control
+ list from other than the local host.
+ */
+#define BadAlloc 11 /* insufficient resources */
+#define BadColor 12 /* no such colormap */
+#define BadGC 13 /* parameter not a GC */
+#define BadIDChoice 14 /* choice not in range or already used */
+#define BadName 15 /* font or color name doesn't exist */
+#define BadLength 16 /* Request length incorrect */
+#define BadImplementation 17 /* server is defective */
+
+#define FirstExtensionError 128
+#define LastExtensionError 255
+
+/*****************************************************************
+ * WINDOW DEFINITIONS
+ *****************************************************************/
+
+/* Window classes used by CreateWindow */
+/* Note that CopyFromParent is already defined as 0 above */
+
+#define InputOutput 1
+#define InputOnly 2
+
+/* Window attributes for CreateWindow and ChangeWindowAttributes */
+
+#define CWBackPixmap (1L<<0)
+#define CWBackPixel (1L<<1)
+#define CWBorderPixmap (1L<<2)
+#define CWBorderPixel (1L<<3)
+#define CWBitGravity (1L<<4)
+#define CWWinGravity (1L<<5)
+#define CWBackingStore (1L<<6)
+#define CWBackingPlanes (1L<<7)
+#define CWBackingPixel (1L<<8)
+#define CWOverrideRedirect (1L<<9)
+#define CWSaveUnder (1L<<10)
+#define CWEventMask (1L<<11)
+#define CWDontPropagate (1L<<12)
+#define CWColormap (1L<<13)
+#define CWCursor (1L<<14)
+
+/* ConfigureWindow structure */
+
+#define CWX (1<<0)
+#define CWY (1<<1)
+#define CWWidth (1<<2)
+#define CWHeight (1<<3)
+#define CWBorderWidth (1<<4)
+#define CWSibling (1<<5)
+#define CWStackMode (1<<6)
+
+
+/* Bit Gravity */
+
+#define ForgetGravity 0
+#define NorthWestGravity 1
+#define NorthGravity 2
+#define NorthEastGravity 3
+#define WestGravity 4
+#define CenterGravity 5
+#define EastGravity 6
+#define SouthWestGravity 7
+#define SouthGravity 8
+#define SouthEastGravity 9
+#define StaticGravity 10
+
+/* Window gravity + bit gravity above */
+
+#define UnmapGravity 0
+
+/* Used in CreateWindow for backing-store hint */
+
+#define NotUseful 0
+#define WhenMapped 1
+#define Always 2
+
+/* Used in GetWindowAttributes reply */
+
+#define IsUnmapped 0
+#define IsUnviewable 1
+#define IsViewable 2
+
+/* Used in ChangeSaveSet */
+
+#define SetModeInsert 0
+#define SetModeDelete 1
+
+/* Used in ChangeCloseDownMode */
+
+#define DestroyAll 0
+#define RetainPermanent 1
+#define RetainTemporary 2
+
+/* Window stacking method (in configureWindow) */
+
+#define Above 0
+#define Below 1
+#define TopIf 2
+#define BottomIf 3
+#define Opposite 4
+
+/* Circulation direction */
+
+#define RaiseLowest 0
+#define LowerHighest 1
+
+/* Property modes */
+
+#define PropModeReplace 0
+#define PropModePrepend 1
+#define PropModeAppend 2
+
+/*****************************************************************
+ * GRAPHICS DEFINITIONS
+ *****************************************************************/
+
+/* graphics functions, as in GC.alu */
+
+#define GXclear 0x0 /* 0 */
+#define GXand 0x1 /* src AND dst */
+#define GXandReverse 0x2 /* src AND NOT dst */
+#define GXcopy 0x3 /* src */
+#define GXandInverted 0x4 /* NOT src AND dst */
+#define GXnoop 0x5 /* dst */
+#define GXxor 0x6 /* src XOR dst */
+#define GXor 0x7 /* src OR dst */
+#define GXnor 0x8 /* NOT src AND NOT dst */
+#define GXequiv 0x9 /* NOT src XOR dst */
+#define GXinvert 0xa /* NOT dst */
+#define GXorReverse 0xb /* src OR NOT dst */
+#define GXcopyInverted 0xc /* NOT src */
+#define GXorInverted 0xd /* NOT src OR dst */
+#define GXnand 0xe /* NOT src OR NOT dst */
+#define GXset 0xf /* 1 */
+
+/* LineStyle */
+
+#define LineSolid 0
+#define LineOnOffDash 1
+#define LineDoubleDash 2
+
+/* capStyle */
+
+#define CapNotLast 0
+#define CapButt 1
+#define CapRound 2
+#define CapProjecting 3
+
+/* joinStyle */
+
+#define JoinMiter 0
+#define JoinRound 1
+#define JoinBevel 2
+
+/* fillStyle */
+
+#define FillSolid 0
+#define FillTiled 1
+#define FillStippled 2
+#define FillOpaqueStippled 3
+
+/* fillRule */
+
+#define EvenOddRule 0
+#define WindingRule 1
+
+/* subwindow mode */
+
+#define ClipByChildren 0
+#define IncludeInferiors 1
+
+/* SetClipRectangles ordering */
+
+#define Unsorted 0
+#define YSorted 1
+#define YXSorted 2
+#define YXBanded 3
+
+/* CoordinateMode for drawing routines */
+
+#define CoordModeOrigin 0 /* relative to the origin */
+#define CoordModePrevious 1 /* relative to previous point */
+
+/* Polygon shapes */
+
+#define Complex 0 /* paths may intersect */
+#define Nonconvex 1 /* no paths intersect, but not convex */
+#define Convex 2 /* wholly convex */
+
+/* Arc modes for PolyFillArc */
+
+#define ArcChord 0 /* join endpoints of arc */
+#define ArcPieSlice 1 /* join endpoints to center of arc */
+
+/* GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into
+ GC.stateChanges */
+
+#define GCFunction (1L<<0)
+#define GCPlaneMask (1L<<1)
+#define GCForeground (1L<<2)
+#define GCBackground (1L<<3)
+#define GCLineWidth (1L<<4)
+#define GCLineStyle (1L<<5)
+#define GCCapStyle (1L<<6)
+#define GCJoinStyle (1L<<7)
+#define GCFillStyle (1L<<8)
+#define GCFillRule (1L<<9)
+#define GCTile (1L<<10)
+#define GCStipple (1L<<11)
+#define GCTileStipXOrigin (1L<<12)
+#define GCTileStipYOrigin (1L<<13)
+#define GCFont (1L<<14)
+#define GCSubwindowMode (1L<<15)
+#define GCGraphicsExposures (1L<<16)
+#define GCClipXOrigin (1L<<17)
+#define GCClipYOrigin (1L<<18)
+#define GCClipMask (1L<<19)
+#define GCDashOffset (1L<<20)
+#define GCDashList (1L<<21)
+#define GCArcMode (1L<<22)
+
+#define GCLastBit 22
+/*****************************************************************
+ * FONTS
+ *****************************************************************/
+
+/* used in QueryFont -- draw direction */
+
+#define FontLeftToRight 0
+#define FontRightToLeft 1
+
+#define FontChange 255
+
+/*****************************************************************
+ * IMAGING
+ *****************************************************************/
+
+/* ImageFormat -- PutImage, GetImage */
+
+#define XYBitmap 0 /* depth 1, XYFormat */
+#define XYPixmap 1 /* depth == drawable depth */
+#define ZPixmap 2 /* depth == drawable depth */
+
+/*****************************************************************
+ * COLOR MAP STUFF
+ *****************************************************************/
+
+/* For CreateColormap */
+
+#define AllocNone 0 /* create map with no entries */
+#define AllocAll 1 /* allocate entire map writeable */
+
+
+/* Flags used in StoreNamedColor, StoreColors */
+
+#define DoRed (1<<0)
+#define DoGreen (1<<1)
+#define DoBlue (1<<2)
+
+/*****************************************************************
+ * CURSOR STUFF
+ *****************************************************************/
+
+/* QueryBestSize Class */
+
+#define CursorShape 0 /* largest size that can be displayed */
+#define TileShape 1 /* size tiled fastest */
+#define StippleShape 2 /* size stippled fastest */
+
+/*****************************************************************
+ * KEYBOARD/POINTER STUFF
+ *****************************************************************/
+
+#define AutoRepeatModeOff 0
+#define AutoRepeatModeOn 1
+#define AutoRepeatModeDefault 2
+
+#define LedModeOff 0
+#define LedModeOn 1
+
+/* masks for ChangeKeyboardControl */
+
+#define KBKeyClickPercent (1L<<0)
+#define KBBellPercent (1L<<1)
+#define KBBellPitch (1L<<2)
+#define KBBellDuration (1L<<3)
+#define KBLed (1L<<4)
+#define KBLedMode (1L<<5)
+#define KBKey (1L<<6)
+#define KBAutoRepeatMode (1L<<7)
+
+#define MappingSuccess 0
+#define MappingBusy 1
+#define MappingFailed 2
+
+#define MappingModifier 0
+#define MappingKeyboard 1
+#define MappingPointer 2
+
+/*****************************************************************
+ * SCREEN SAVER STUFF
+ *****************************************************************/
+
+#define DontPreferBlanking 0
+#define PreferBlanking 1
+#define DefaultBlanking 2
+
+#define DisableScreenSaver 0
+#define DisableScreenInterval 0
+
+#define DontAllowExposures 0
+#define AllowExposures 1
+#define DefaultExposures 2
+
+/* for ForceScreenSaver */
+
+#define ScreenSaverReset 0
+#define ScreenSaverActive 1
+
+/*****************************************************************
+ * HOSTS AND CONNECTIONS
+ *****************************************************************/
+
+/* for ChangeHosts */
+
+#define HostInsert 0
+#define HostDelete 1
+
+/* for ChangeAccessControl */
+
+#define EnableAccess 1
+#define DisableAccess 0
+
+/* Display classes used in opening the connection
+ * Note that the statically allocated ones are even numbered and the
+ * dynamically changeable ones are odd numbered */
+
+#define StaticGray 0
+#define GrayScale 1
+#define StaticColor 2
+#define PseudoColor 3
+#define TrueColor 4
+#define DirectColor 5
+
+
+/* Byte order used in imageByteOrder and bitmapBitOrder */
+
+#define LSBFirst 0
+#define MSBFirst 1
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Cursor
+# undef Region
+#endif
+
+#endif /* X_H */
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h
new file mode 100644
index 00000000000..485a4236db8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xatom.h
@@ -0,0 +1,79 @@
+#ifndef XATOM_H
+#define XATOM_H 1
+
+/* THIS IS A GENERATED FILE
+ *
+ * Do not change! Changing this file implies a protocol change!
+ */
+
+#define XA_PRIMARY ((Atom) 1)
+#define XA_SECONDARY ((Atom) 2)
+#define XA_ARC ((Atom) 3)
+#define XA_ATOM ((Atom) 4)
+#define XA_BITMAP ((Atom) 5)
+#define XA_CARDINAL ((Atom) 6)
+#define XA_COLORMAP ((Atom) 7)
+#define XA_CURSOR ((Atom) 8)
+#define XA_CUT_BUFFER0 ((Atom) 9)
+#define XA_CUT_BUFFER1 ((Atom) 10)
+#define XA_CUT_BUFFER2 ((Atom) 11)
+#define XA_CUT_BUFFER3 ((Atom) 12)
+#define XA_CUT_BUFFER4 ((Atom) 13)
+#define XA_CUT_BUFFER5 ((Atom) 14)
+#define XA_CUT_BUFFER6 ((Atom) 15)
+#define XA_CUT_BUFFER7 ((Atom) 16)
+#define XA_DRAWABLE ((Atom) 17)
+#define XA_FONT ((Atom) 18)
+#define XA_INTEGER ((Atom) 19)
+#define XA_PIXMAP ((Atom) 20)
+#define XA_POINT ((Atom) 21)
+#define XA_RECTANGLE ((Atom) 22)
+#define XA_RESOURCE_MANAGER ((Atom) 23)
+#define XA_RGB_COLOR_MAP ((Atom) 24)
+#define XA_RGB_BEST_MAP ((Atom) 25)
+#define XA_RGB_BLUE_MAP ((Atom) 26)
+#define XA_RGB_DEFAULT_MAP ((Atom) 27)
+#define XA_RGB_GRAY_MAP ((Atom) 28)
+#define XA_RGB_GREEN_MAP ((Atom) 29)
+#define XA_RGB_RED_MAP ((Atom) 30)
+#define XA_STRING ((Atom) 31)
+#define XA_VISUALID ((Atom) 32)
+#define XA_WINDOW ((Atom) 33)
+#define XA_WM_COMMAND ((Atom) 34)
+#define XA_WM_HINTS ((Atom) 35)
+#define XA_WM_CLIENT_MACHINE ((Atom) 36)
+#define XA_WM_ICON_NAME ((Atom) 37)
+#define XA_WM_ICON_SIZE ((Atom) 38)
+#define XA_WM_NAME ((Atom) 39)
+#define XA_WM_NORMAL_HINTS ((Atom) 40)
+#define XA_WM_SIZE_HINTS ((Atom) 41)
+#define XA_WM_ZOOM_HINTS ((Atom) 42)
+#define XA_MIN_SPACE ((Atom) 43)
+#define XA_NORM_SPACE ((Atom) 44)
+#define XA_MAX_SPACE ((Atom) 45)
+#define XA_END_SPACE ((Atom) 46)
+#define XA_SUPERSCRIPT_X ((Atom) 47)
+#define XA_SUPERSCRIPT_Y ((Atom) 48)
+#define XA_SUBSCRIPT_X ((Atom) 49)
+#define XA_SUBSCRIPT_Y ((Atom) 50)
+#define XA_UNDERLINE_POSITION ((Atom) 51)
+#define XA_UNDERLINE_THICKNESS ((Atom) 52)
+#define XA_STRIKEOUT_ASCENT ((Atom) 53)
+#define XA_STRIKEOUT_DESCENT ((Atom) 54)
+#define XA_ITALIC_ANGLE ((Atom) 55)
+#define XA_X_HEIGHT ((Atom) 56)
+#define XA_QUAD_WIDTH ((Atom) 57)
+#define XA_WEIGHT ((Atom) 58)
+#define XA_POINT_SIZE ((Atom) 59)
+#define XA_RESOLUTION ((Atom) 60)
+#define XA_COPYRIGHT ((Atom) 61)
+#define XA_NOTICE ((Atom) 62)
+#define XA_FONT_NAME ((Atom) 63)
+#define XA_FAMILY_NAME ((Atom) 64)
+#define XA_FULL_NAME ((Atom) 65)
+#define XA_CAP_HEIGHT ((Atom) 66)
+#define XA_WM_CLASS ((Atom) 67)
+#define XA_WM_TRANSIENT_FOR ((Atom) 68)
+
+#define XA_LAST_PREDEFINED ((Atom) 68)
+#endif /* XATOM_H */
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h
new file mode 100644
index 00000000000..a59379b3b65
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xfuncproto.h
@@ -0,0 +1,60 @@
+/* $XConsortium: Xfuncproto.h,v 1.7 91/05/13 20:49:21 rws Exp $ */
+/*
+ * Copyright 1989, 1991 by the Massachusetts Institute of Technology
+ *
+ * Permission to use, copy, modify, and distribute this software and its
+ * documentation for any purpose and without fee is hereby granted, provided
+ * that the above copyright notice appear in all copies and that both that
+ * copyright notice and this permission notice appear in supporting
+ * documentation, and that the name of M.I.T. not be used in advertising
+ * or publicity pertaining to distribution of the software without specific,
+ * written prior permission. M.I.T. makes no representations about the
+ * suitability of this software for any purpose. It is provided "as is"
+ * without express or implied warranty.
+ *
+ */
+
+/* Definitions to make function prototypes manageable */
+
+#ifndef _XFUNCPROTO_H_
+#define _XFUNCPROTO_H_
+
+#ifndef NeedFunctionPrototypes
+#define NeedFunctionPrototypes 1
+#endif /* NeedFunctionPrototypes */
+
+#ifndef NeedVarargsPrototypes
+#define NeedVarargsPrototypes 0
+#endif /* NeedVarargsPrototypes */
+
+#if NeedFunctionPrototypes
+
+#ifndef NeedNestedPrototypes
+#define NeedNestedPrototypes 1
+#endif /* NeedNestedPrototypes */
+
+#ifndef _Xconst
+#define _Xconst const
+#endif /* _Xconst */
+
+#ifndef NeedWidePrototypes
+#ifdef NARROWPROTO
+#define NeedWidePrototypes 0
+#else
+#define NeedWidePrototypes 1 /* default to make interropt. easier */
+#endif
+#endif /* NeedWidePrototypes */
+
+#endif /* NeedFunctionPrototypes */
+
+#ifdef __cplusplus
+#define _XFUNCPROTOBEGIN extern "C" {
+#define _XFUNCPROTOEND }
+#endif
+
+#ifndef _XFUNCPROTOBEGIN
+#define _XFUNCPROTOBEGIN
+#define _XFUNCPROTOEND
+#endif /* _XFUNCPROTOBEGIN */
+
+#endif /* _XFUNCPROTO_H_ */
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h
new file mode 100644
index 00000000000..0a9e3ddd45d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xlib.h
@@ -0,0 +1,1214 @@
+/* $XConsortium: Xlib.h,v 11.221 93/07/02 14:13:28 gildea Exp $ */
+/*
+ * Copyright 1985, 1986, 1987, 1991 by the Massachusetts Institute of Technology
+ *
+ * Permission to use, copy, modify, and distribute this software and its
+ * documentation for any purpose and without fee is hereby granted, provided
+ * that the above copyright notice appear in all copies and that both that
+ * copyright notice and this permission notice appear in supporting
+ * documentation, and that the name of M.I.T. not be used in advertising
+ * or publicity pertaining to distribution of the software without specific,
+ * written prior permission. M.I.T. makes no representations about the
+ * suitability of this software for any purpose. It is provided "as is"
+ * without express or implied warranty.
+ *
+ * X Window System is a Trademark of MIT.
+ *
+ */
+
+
+/*
+ * Xlib.h - Header definition and support file for the C subroutine
+ * interface library (Xlib) to the X Window System Protocol (V11).
+ * Structures and symbols starting with "_" are private to the library.
+ */
+#ifndef _XLIB_H_
+#define _XLIB_H_
+
+#define XlibSpecificationRelease 5
+
+#if !defined(MAC_TCL) && !defined(MAC_OSX_TK)
+# include <X11/X.h>
+#endif
+#ifdef MAC_TCL
+# include <X.h>
+# define Cursor XCursor
+# define Region XRegion
+#endif
+#ifdef MAC_OSX_TK
+# include <X11/X.h>
+# define Cursor XCursor
+# define Region XRegion
+#endif
+
+/* applications should not depend on these two headers being included! */
+#ifdef MAC_TCL
+#include <Xfuncproto.h>
+#else
+#include <X11/Xfuncproto.h>
+#endif
+
+#ifndef X_WCHAR
+#ifdef X_NOT_STDC_ENV
+#define X_WCHAR
+#endif
+#endif
+
+#ifndef X_WCHAR
+#include <stddef.h>
+#else
+/* replace this with #include or typedef appropriate for your system */
+typedef unsigned long wchar_t;
+#endif
+
+typedef char *XPointer;
+
+#define Bool int
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+/* Use define rather than typedef, since may need to undefine this later */
+#define Status int
+#else
+typedef int Status;
+#endif
+#define True 1
+#define False 0
+
+#define QueuedAlready 0
+#define QueuedAfterReading 1
+#define QueuedAfterFlush 2
+
+#define ConnectionNumber(dpy) ((dpy)->fd)
+#define RootWindow(dpy, scr) (((dpy)->screens[(scr)]).root)
+#define DefaultScreen(dpy) ((dpy)->default_screen)
+#define DefaultRootWindow(dpy) (((dpy)->screens[(dpy)->default_screen]).root)
+#define DefaultVisual(dpy, scr) (((dpy)->screens[(scr)]).root_visual)
+#define DefaultGC(dpy, scr) (((dpy)->screens[(scr)]).default_gc)
+#define BlackPixel(dpy, scr) (((dpy)->screens[(scr)]).black_pixel)
+#define WhitePixel(dpy, scr) (((dpy)->screens[(scr)]).white_pixel)
+#define AllPlanes ((unsigned long)~0L)
+#define QLength(dpy) ((dpy)->qlen)
+#define DisplayWidth(dpy, scr) (((dpy)->screens[(scr)]).width)
+#define DisplayHeight(dpy, scr) (((dpy)->screens[(scr)]).height)
+#define DisplayWidthMM(dpy, scr)(((dpy)->screens[(scr)]).mwidth)
+#define DisplayHeightMM(dpy, scr)(((dpy)->screens[(scr)]).mheight)
+#define DisplayPlanes(dpy, scr) (((dpy)->screens[(scr)]).root_depth)
+#define DisplayCells(dpy, scr) (DefaultVisual((dpy), (scr))->map_entries)
+#define ScreenCount(dpy) ((dpy)->nscreens)
+#define ServerVendor(dpy) ((dpy)->vendor)
+#define ProtocolVersion(dpy) ((dpy)->proto_major_version)
+#define ProtocolRevision(dpy) ((dpy)->proto_minor_version)
+#define VendorRelease(dpy) ((dpy)->release)
+#define DisplayString(dpy) ((dpy)->display_name)
+#define DefaultDepth(dpy, scr) (((dpy)->screens[(scr)]).root_depth)
+#define DefaultColormap(dpy, scr)(((dpy)->screens[(scr)]).cmap)
+#define BitmapUnit(dpy) ((dpy)->bitmap_unit)
+#define BitmapBitOrder(dpy) ((dpy)->bitmap_bit_order)
+#define BitmapPad(dpy) ((dpy)->bitmap_pad)
+#define ImageByteOrder(dpy) ((dpy)->byte_order)
+#define NextRequest(dpy) ((dpy)->request + 1)
+#define LastKnownRequestProcessed(dpy) ((dpy)->last_request_read)
+
+/* macros for screen oriented applications (toolkit) */
+#define ScreenOfDisplay(dpy, scr)(&((dpy)->screens[(scr)]))
+#define DefaultScreenOfDisplay(dpy) (&((dpy)->screens[(dpy)->default_screen]))
+#define DisplayOfScreen(s) ((s)->display)
+#define RootWindowOfScreen(s) ((s)->root)
+#define BlackPixelOfScreen(s) ((s)->black_pixel)
+#define WhitePixelOfScreen(s) ((s)->white_pixel)
+#define DefaultColormapOfScreen(s)((s)->cmap)
+#define DefaultDepthOfScreen(s) ((s)->root_depth)
+#define DefaultGCOfScreen(s) ((s)->default_gc)
+#define DefaultVisualOfScreen(s)((s)->root_visual)
+#define WidthOfScreen(s) ((s)->width)
+#define HeightOfScreen(s) ((s)->height)
+#define WidthMMOfScreen(s) ((s)->mwidth)
+#define HeightMMOfScreen(s) ((s)->mheight)
+#define PlanesOfScreen(s) ((s)->root_depth)
+#define CellsOfScreen(s) (DefaultVisualOfScreen((s))->map_entries)
+#define MinCmapsOfScreen(s) ((s)->min_maps)
+#define MaxCmapsOfScreen(s) ((s)->max_maps)
+#define DoesSaveUnders(s) ((s)->save_unders)
+#define DoesBackingStore(s) ((s)->backing_store)
+#define EventMaskOfScreen(s) ((s)->root_input_mask)
+
+/*
+ * Extensions need a way to hang private data on some structures.
+ */
+typedef struct _XExtData {
+ int number; /* number returned by XRegisterExtension */
+ struct _XExtData *next; /* next item on list of data for structure */
+ int (*free_private)(); /* called to free private storage */
+ XPointer private_data; /* data private to this extension. */
+} XExtData;
+
+/*
+ * This file contains structures used by the extension mechanism.
+ */
+typedef struct { /* public to extension, cannot be changed */
+ int extension; /* extension number */
+ int major_opcode; /* major op-code assigned by server */
+ int first_event; /* first event number for the extension */
+ int first_error; /* first error number for the extension */
+} XExtCodes;
+
+/*
+ * Data structure for retrieving info about pixmap formats.
+ */
+
+typedef struct {
+ int depth;
+ int bits_per_pixel;
+ int scanline_pad;
+} XPixmapFormatValues;
+
+
+/*
+ * Data structure for setting graphics context.
+ */
+typedef struct {
+ int function; /* logical operation */
+ unsigned long plane_mask;/* plane mask */
+ unsigned long foreground;/* foreground pixel */
+ unsigned long background;/* background pixel */
+ int line_width; /* line width */
+ int line_style; /* LineSolid, LineOnOffDash, LineDoubleDash */
+ int cap_style; /* CapNotLast, CapButt,
+ CapRound, CapProjecting */
+ int join_style; /* JoinMiter, JoinRound, JoinBevel */
+ int fill_style; /* FillSolid, FillTiled,
+ FillStippled, FillOpaeueStippled */
+ int fill_rule; /* EvenOddRule, WindingRule */
+ int arc_mode; /* ArcChord, ArcPieSlice */
+ Pixmap tile; /* tile pixmap for tiling operations */
+ Pixmap stipple; /* stipple 1 plane pixmap for stipping */
+ int ts_x_origin; /* offset for tile or stipple operations */
+ int ts_y_origin;
+ Font font; /* default text font for text operations */
+ int subwindow_mode; /* ClipByChildren, IncludeInferiors */
+ Bool graphics_exposures;/* boolean, should exposures be generated */
+ int clip_x_origin; /* origin for clipping */
+ int clip_y_origin;
+ Pixmap clip_mask; /* bitmap clipping; other calls for rects */
+ int dash_offset; /* patterned/dashed line information */
+ char dashes;
+} XGCValues;
+
+/*
+ * Graphics context. The contents of this structure are implementation
+ * dependent. A GC should be treated as opaque by application code.
+ */
+
+typedef XGCValues *GC;
+
+/*
+ * Visual structure; contains information about colormapping possible.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ VisualID visualid; /* visual id of this visual */
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ class of screen (monochrome, etc.) */
+#else
+ int class; /* class of screen (monochrome, etc.) */
+#endif
+ unsigned long red_mask, green_mask, blue_mask; /* mask values */
+ int bits_per_rgb; /* log base 2 of distinct color values */
+ int map_entries; /* color map entries */
+} Visual;
+
+/*
+ * Depth structure; contains information for each possible depth.
+ */
+typedef struct {
+ int depth; /* this depth (Z) of the depth */
+ int nvisuals; /* number of Visual types at this depth */
+ Visual *visuals; /* list of visuals possible at this depth */
+} Depth;
+
+/*
+ * Information about the screen. The contents of this structure are
+ * implementation dependent. A Screen should be treated as opaque
+ * by application code.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ struct _XDisplay *display;/* back pointer to display structure */
+ Window root; /* Root window id. */
+ int width, height; /* width and height of screen */
+ int mwidth, mheight; /* width and height of in millimeters */
+ int ndepths; /* number of depths possible */
+ Depth *depths; /* list of allowable depths on the screen */
+ int root_depth; /* bits per pixel */
+ Visual *root_visual; /* root visual */
+ GC default_gc; /* GC for the root root visual */
+ Colormap cmap; /* default color map */
+ unsigned long white_pixel;
+ unsigned long black_pixel; /* White and Black pixel values */
+ int max_maps, min_maps; /* max and min color maps */
+ int backing_store; /* Never, WhenMapped, Always */
+ Bool save_unders;
+ long root_input_mask; /* initial root input mask */
+} Screen;
+
+/*
+ * Format structure; describes ZFormat data the screen will understand.
+ */
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ int depth; /* depth of this image format */
+ int bits_per_pixel; /* bits/pixel at this depth */
+ int scanline_pad; /* scanline must padded to this multiple */
+} ScreenFormat;
+
+/*
+ * Data structure for setting window attributes.
+ */
+typedef struct {
+ Pixmap background_pixmap; /* background or None or ParentRelative */
+ unsigned long background_pixel; /* background pixel */
+ Pixmap border_pixmap; /* border of the window */
+ unsigned long border_pixel; /* border pixel value */
+ int bit_gravity; /* one of bit gravity values */
+ int win_gravity; /* one of the window gravity values */
+ int backing_store; /* NotUseful, WhenMapped, Always */
+ unsigned long backing_planes;/* planes to be preseved if possible */
+ unsigned long backing_pixel;/* value to use in restoring planes */
+ Bool save_under; /* should bits under be saved? (popups) */
+ long event_mask; /* set of events that should be saved */
+ long do_not_propagate_mask; /* set of events that should not propagate */
+ Bool override_redirect; /* boolean value for override-redirect */
+ Colormap colormap; /* color map to be associated with window */
+ Cursor cursor; /* cursor to be displayed (or None) */
+} XSetWindowAttributes;
+
+typedef struct {
+ int x, y; /* location of window */
+ int width, height; /* width and height of window */
+ int border_width; /* border width of window */
+ int depth; /* depth of window */
+ Visual *visual; /* the associated visual structure */
+ Window root; /* root of screen containing window */
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ InputOutput, InputOnly*/
+#else
+ int class; /* InputOutput, InputOnly*/
+#endif
+ int bit_gravity; /* one of bit gravity values */
+ int win_gravity; /* one of the window gravity values */
+ int backing_store; /* NotUseful, WhenMapped, Always */
+ unsigned long backing_planes;/* planes to be preserved if possible */
+ unsigned long backing_pixel;/* value to be used when restoring planes */
+ Bool save_under; /* boolean, should bits under be saved? */
+ Colormap colormap; /* color map to be associated with window */
+ Bool map_installed; /* boolean, is color map currently installed*/
+ int map_state; /* IsUnmapped, IsUnviewable, IsViewable */
+ long all_event_masks; /* set of events all people have interest in*/
+ long your_event_mask; /* my event mask */
+ long do_not_propagate_mask; /* set of events that should not propagate */
+ Bool override_redirect; /* boolean value for override-redirect */
+ Screen *screen; /* back pointer to correct screen */
+} XWindowAttributes;
+
+/*
+ * Data structure for host setting; getting routines.
+ *
+ */
+
+typedef struct {
+ int family; /* for example FamilyInternet */
+ int length; /* length of address, in bytes */
+ char *address; /* pointer to where to find the bytes */
+} XHostAddress;
+
+/*
+ * Data structure for "image" data, used by image manipulation routines.
+ */
+typedef struct _XImage {
+ int width, height; /* size of image */
+ int xoffset; /* number of pixels offset in X direction */
+ int format; /* XYBitmap, XYPixmap, ZPixmap */
+ char *data; /* pointer to image data */
+ int byte_order; /* data byte order, LSBFirst, MSBFirst */
+ int bitmap_unit; /* quant. of scanline 8, 16, 32 */
+ int bitmap_bit_order; /* LSBFirst, MSBFirst */
+ int bitmap_pad; /* 8, 16, 32 either XY or ZPixmap */
+ int depth; /* depth of image */
+ int bytes_per_line; /* accelarator to next line */
+ int bits_per_pixel; /* bits per pixel (ZPixmap) */
+ unsigned long red_mask; /* bits in z arrangment */
+ unsigned long green_mask;
+ unsigned long blue_mask;
+ XPointer obdata; /* hook for the object routines to hang on */
+ struct funcs { /* image manipulation routines */
+ struct _XImage *(*create_image)();
+#if NeedFunctionPrototypes
+ int (*destroy_image) (struct _XImage *);
+ unsigned long (*get_pixel) (struct _XImage *, int, int);
+ int (*put_pixel) (struct _XImage *, int, int, unsigned long);
+ struct _XImage *(*sub_image)(struct _XImage *, int, int, unsigned int, unsigned int);
+ int (*add_pixel) (struct _XImage *, long);
+#else
+ int (*destroy_image)();
+ unsigned long (*get_pixel)();
+ int (*put_pixel)();
+ struct _XImage *(*sub_image)();
+ int (*add_pixel)();
+#endif
+ } f;
+} XImage;
+
+/*
+ * Data structure for XReconfigureWindow
+ */
+typedef struct {
+ int x, y;
+ int width, height;
+ int border_width;
+ Window sibling;
+ int stack_mode;
+} XWindowChanges;
+
+/*
+ * Data structure used by color operations
+ */
+typedef struct {
+ unsigned long pixel;
+ unsigned short red, green, blue;
+ char flags; /* do_red, do_green, do_blue */
+ char pad;
+} XColor;
+
+/*
+ * Data structures for graphics operations. On most machines, these are
+ * congruent with the wire protocol structures, so reformatting the data
+ * can be avoided on these architectures.
+ */
+typedef struct {
+ short x1, y1, x2, y2;
+} XSegment;
+
+typedef struct {
+ short x, y;
+} XPoint;
+
+typedef struct {
+ short x, y;
+ unsigned short width, height;
+} XRectangle;
+
+typedef struct {
+ short x, y;
+ unsigned short width, height;
+ short angle1, angle2;
+} XArc;
+
+
+/* Data structure for XChangeKeyboardControl */
+
+typedef struct {
+ int key_click_percent;
+ int bell_percent;
+ int bell_pitch;
+ int bell_duration;
+ int led;
+ int led_mode;
+ int key;
+ int auto_repeat_mode; /* On, Off, Default */
+} XKeyboardControl;
+
+/* Data structure for XGetKeyboardControl */
+
+typedef struct {
+ int key_click_percent;
+ int bell_percent;
+ unsigned int bell_pitch, bell_duration;
+ unsigned long led_mask;
+ int global_auto_repeat;
+ char auto_repeats[32];
+} XKeyboardState;
+
+/* Data structure for XGetMotionEvents. */
+
+typedef struct {
+ Time time;
+ short x, y;
+} XTimeCoord;
+
+/* Data structure for X{Set,Get}ModifierMapping */
+
+typedef struct {
+ int max_keypermod; /* The server's max # of keys per modifier */
+ KeyCode *modifiermap; /* An 8 by max_keypermod array of modifiers */
+} XModifierKeymap;
+
+
+/*
+ * Display datatype maintaining display specific data.
+ * The contents of this structure are implementation dependent.
+ * A Display should be treated as opaque by application code.
+ */
+typedef struct _XDisplay {
+ XExtData *ext_data; /* hook for extension to hang data */
+ struct _XFreeFuncs *free_funcs; /* internal free functions */
+ int fd; /* Network socket. */
+ int conn_checker; /* ugly thing used by _XEventsQueued */
+ int proto_major_version;/* maj. version of server's X protocol */
+ int proto_minor_version;/* minor version of servers X protocol */
+ char *vendor; /* vendor of the server hardware */
+ XID resource_base; /* resource ID base */
+ XID resource_mask; /* resource ID mask bits */
+ XID resource_id; /* allocator current ID */
+ int resource_shift; /* allocator shift to correct bits */
+ XID (*resource_alloc)(); /* allocator function */
+ int byte_order; /* screen byte order, LSBFirst, MSBFirst */
+ int bitmap_unit; /* padding and data requirements */
+ int bitmap_pad; /* padding requirements on bitmaps */
+ int bitmap_bit_order; /* LeastSignificant or MostSignificant */
+ int nformats; /* number of pixmap formats in list */
+ ScreenFormat *pixmap_format; /* pixmap format list */
+ int vnumber; /* Xlib's X protocol version number. */
+ int release; /* release of the server */
+ struct _XSQEvent *head, *tail; /* Input event queue. */
+ int qlen; /* Length of input event queue */
+ unsigned long last_request_read; /* seq number of last event read */
+ unsigned long request; /* sequence number of last request. */
+ char *last_req; /* beginning of last request, or dummy */
+ char *buffer; /* Output buffer starting address. */
+ char *bufptr; /* Output buffer index pointer. */
+ char *bufmax; /* Output buffer maximum+1 address. */
+ unsigned max_request_size; /* maximum number 32 bit words in request*/
+ struct _XrmHashBucketRec *db;
+ int (*synchandler)(); /* Synchronization handler */
+ char *display_name; /* "host:display" string used on this connect*/
+ int default_screen; /* default screen for operations */
+ int nscreens; /* number of screens on this server*/
+ Screen *screens; /* pointer to list of screens */
+ unsigned long motion_buffer; /* size of motion buffer */
+ unsigned long flags; /* internal connection flags */
+ int min_keycode; /* minimum defined keycode */
+ int max_keycode; /* maximum defined keycode */
+ KeySym *keysyms; /* This server's keysyms */
+ XModifierKeymap *modifiermap; /* This server's modifier keymap */
+ int keysyms_per_keycode;/* number of rows */
+ char *xdefaults; /* contents of defaults from server */
+ char *scratch_buffer; /* place to hang scratch buffer */
+ unsigned long scratch_length; /* length of scratch buffer */
+ int ext_number; /* extension number on this display */
+ struct _XExten *ext_procs; /* extensions initialized on this display */
+ /*
+ * the following can be fixed size, as the protocol defines how
+ * much address space is available.
+ * While this could be done using the extension vector, there
+ * may be MANY events processed, so a search through the extension
+ * list to find the right procedure for each event might be
+ * expensive if many extensions are being used.
+ */
+ Bool (*event_vec[128])(); /* vector for wire to event */
+ int (*wire_vec[128])(); /* vector for event to wire */
+ KeySym lock_meaning; /* for XLookupString */
+ struct _XLockInfo *lock; /* multi-thread state, display lock */
+ struct _XInternalAsync *async_handlers; /* for internal async */
+ unsigned long bigreq_size; /* max size of big requests */
+ struct _XLockPtrs *lock_fns; /* pointers to threads functions */
+ /* things above this line should not move, for binary compatibility */
+ struct _XKeytrans *key_bindings; /* for XLookupString */
+ Font cursor_font; /* for XCreateFontCursor */
+ struct _XDisplayAtoms *atoms; /* for XInternAtom */
+ unsigned int mode_switch; /* keyboard group modifiers */
+ struct _XContextDB *context_db; /* context database */
+ Bool (**error_vec)(); /* vector for wire to error */
+ /*
+ * Xcms information
+ */
+ struct {
+ XPointer defaultCCCs; /* pointer to an array of default XcmsCCC */
+ XPointer clientCmaps; /* pointer to linked list of XcmsCmapRec */
+ XPointer perVisualIntensityMaps;
+ /* linked list of XcmsIntensityMap */
+ } cms;
+ struct _XIMFilter *im_filters;
+ struct _XSQEvent *qfree; /* unallocated event queue elements */
+ unsigned long next_event_serial_num; /* inserted into next queue elt */
+ int (*savedsynchandler)(); /* user synchandler when Xlib usurps */
+} Display;
+
+#if NeedFunctionPrototypes /* prototypes require event type definitions */
+#undef _XEVENT_
+#endif
+#ifndef _XEVENT_
+
+#define XMaxTransChars 4
+
+/*
+ * Definitions of specific events.
+ */
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window it is reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ unsigned int keycode; /* detail */
+ Bool same_screen; /* same screen flag */
+ char trans_chars[XMaxTransChars];
+ /* translated characters */
+ int nbytes;
+} XKeyEvent;
+typedef XKeyEvent XKeyPressedEvent;
+typedef XKeyEvent XKeyReleasedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window it is reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ unsigned int button; /* detail */
+ Bool same_screen; /* same screen flag */
+} XButtonEvent;
+typedef XButtonEvent XButtonPressedEvent;
+typedef XButtonEvent XButtonReleasedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ unsigned int state; /* key or button mask */
+ char is_hint; /* detail */
+ Bool same_screen; /* same screen flag */
+} XMotionEvent;
+typedef XMotionEvent XPointerMovedEvent;
+
+typedef struct {
+ int type; /* of event */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* "event" window reported relative to */
+ Window root; /* root window that the event occured on */
+ Window subwindow; /* child window */
+ Time time; /* milliseconds */
+ int x, y; /* pointer x, y coordinates in event window */
+ int x_root, y_root; /* coordinates relative to root */
+ int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */
+ int detail;
+ /*
+ * NotifyAncestor, NotifyVirtual, NotifyInferior,
+ * NotifyNonlinear,NotifyNonlinearVirtual
+ */
+ Bool same_screen; /* same screen flag */
+ Bool focus; /* boolean focus */
+ unsigned int state; /* key or button mask */
+} XCrossingEvent;
+typedef XCrossingEvent XEnterWindowEvent;
+typedef XCrossingEvent XLeaveWindowEvent;
+
+typedef struct {
+ int type; /* FocusIn or FocusOut */
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* window of event */
+ int mode; /* NotifyNormal, NotifyGrab, NotifyUngrab */
+ int detail;
+ /*
+ * NotifyAncestor, NotifyVirtual, NotifyInferior,
+ * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer,
+ * NotifyPointerRoot, NotifyDetailNone
+ */
+} XFocusChangeEvent;
+typedef XFocusChangeEvent XFocusInEvent;
+typedef XFocusChangeEvent XFocusOutEvent;
+
+/* generated on EnterWindow and FocusIn when KeyMapState selected */
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ char key_vector[32];
+} XKeymapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int x, y;
+ int width, height;
+ int count; /* if non-zero, at least this many more */
+} XExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Drawable drawable;
+ int x, y;
+ int width, height;
+ int count; /* if non-zero, at least this many more */
+ int major_code; /* core is CopyArea or CopyPlane */
+ int minor_code; /* not defined in the core */
+} XGraphicsExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Drawable drawable;
+ int major_code; /* core is CopyArea or CopyPlane */
+ int minor_code; /* not defined in the core */
+} XNoExposeEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int state; /* Visibility state */
+} XVisibilityEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent; /* parent of the window */
+ Window window; /* window id of window created */
+ int x, y; /* window location */
+ int width, height; /* size of window */
+ int border_width; /* border width */
+ Bool override_redirect; /* creation should be overridden */
+} XCreateWindowEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+} XDestroyWindowEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Bool from_configure;
+} XUnmapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Bool override_redirect; /* boolean, is override set... */
+} XMapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+} XMapRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ Window parent;
+ int x, y;
+ Bool override_redirect;
+} XReparentEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int x, y;
+ int width, height;
+ int border_width;
+ Window above;
+ Bool override_redirect;
+} XConfigureEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int x, y;
+} XGravityEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ int width, height;
+} XResizeRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+ int x, y;
+ int width, height;
+ int border_width;
+ Window above;
+ int detail; /* Above, Below, TopIf, BottomIf, Opposite */
+ unsigned long value_mask;
+} XConfigureRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window event;
+ Window window;
+ int place; /* PlaceOnTop, PlaceOnBottom */
+} XCirculateEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window parent;
+ Window window;
+ int place; /* PlaceOnTop, PlaceOnBottom */
+} XCirculateRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom atom;
+ Time time;
+ int state; /* NewValue, Deleted */
+} XPropertyEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom selection;
+ Time time;
+} XSelectionClearEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window owner;
+ Window requestor;
+ Atom selection;
+ Atom target;
+ Atom property;
+ Time time;
+} XSelectionRequestEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window requestor;
+ Atom selection;
+ Atom target;
+ Atom property; /* ATOM or None */
+ Time time;
+} XSelectionEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Colormap colormap; /* COLORMAP or None */
+#if defined(__cplusplus) || defined(c_plusplus)
+ Bool c_new; /* C++ */
+#else
+ Bool new;
+#endif
+ int state; /* ColormapInstalled, ColormapUninstalled */
+} XColormapEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window;
+ Atom message_type;
+ int format;
+ union {
+ char b[20];
+ short s[10];
+ long l[5];
+ } data;
+} XClientMessageEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display; /* Display the event was read from */
+ Window window; /* unused */
+ int request; /* one of MappingModifier, MappingKeyboard,
+ MappingPointer */
+ int first_keycode; /* first keycode */
+ int count; /* defines range of change w. first_keycode*/
+} XMappingEvent;
+
+typedef struct {
+ int type;
+ Display *display; /* Display the event was read from */
+ XID resourceid; /* resource id */
+ unsigned long serial; /* serial number of failed request */
+ unsigned char error_code; /* error code of failed request */
+ unsigned char request_code; /* Major op-code of failed request */
+ unsigned char minor_code; /* Minor op-code of failed request */
+} XErrorEvent;
+
+typedef struct {
+ int type;
+ unsigned long serial; /* # of last request processed by server */
+ Bool send_event; /* true if this came from a SendEvent request */
+ Display *display;/* Display the event was read from */
+ Window window; /* window on which event was requested in event mask */
+} XAnyEvent;
+
+/*
+ * this union is defined so Xlib can always use the same sized
+ * event structure internally, to avoid memory fragmentation.
+ */
+typedef union _XEvent {
+ int type; /* must not be changed; first element */
+ XAnyEvent xany;
+ XKeyEvent xkey;
+ XButtonEvent xbutton;
+ XMotionEvent xmotion;
+ XCrossingEvent xcrossing;
+ XFocusChangeEvent xfocus;
+ XExposeEvent xexpose;
+ XGraphicsExposeEvent xgraphicsexpose;
+ XNoExposeEvent xnoexpose;
+ XVisibilityEvent xvisibility;
+ XCreateWindowEvent xcreatewindow;
+ XDestroyWindowEvent xdestroywindow;
+ XUnmapEvent xunmap;
+ XMapEvent xmap;
+ XMapRequestEvent xmaprequest;
+ XReparentEvent xreparent;
+ XConfigureEvent xconfigure;
+ XGravityEvent xgravity;
+ XResizeRequestEvent xresizerequest;
+ XConfigureRequestEvent xconfigurerequest;
+ XCirculateEvent xcirculate;
+ XCirculateRequestEvent xcirculaterequest;
+ XPropertyEvent xproperty;
+ XSelectionClearEvent xselectionclear;
+ XSelectionRequestEvent xselectionrequest;
+ XSelectionEvent xselection;
+ XColormapEvent xcolormap;
+ XClientMessageEvent xclient;
+ XMappingEvent xmapping;
+ XErrorEvent xerror;
+ XKeymapEvent xkeymap;
+ long pad[24];
+} XEvent;
+#endif
+
+#define XAllocID(dpy) ((*(dpy)->resource_alloc)((dpy)))
+
+/*
+ * per character font metric information.
+ */
+typedef struct {
+ short lbearing; /* origin to left edge of raster */
+ short rbearing; /* origin to right edge of raster */
+ short width; /* advance to next char's origin */
+ short ascent; /* baseline to top edge of raster */
+ short descent; /* baseline to bottom edge of raster */
+ unsigned short attributes; /* per char flags (not predefined) */
+} XCharStruct;
+
+/*
+ * To allow arbitrary information with fonts, there are additional properties
+ * returned.
+ */
+typedef struct {
+ Atom name;
+ unsigned long card32;
+} XFontProp;
+
+typedef struct {
+ XExtData *ext_data; /* hook for extension to hang data */
+ Font fid; /* Font id for this font */
+ unsigned direction; /* hint about direction the font is painted */
+ unsigned min_char_or_byte2;/* first character */
+ unsigned max_char_or_byte2;/* last character */
+ unsigned min_byte1; /* first row that exists */
+ unsigned max_byte1; /* last row that exists */
+ Bool all_chars_exist;/* flag if all characters have non-zero size*/
+ unsigned default_char; /* char to print for undefined character */
+ int n_properties; /* how many properties there are */
+ XFontProp *properties; /* pointer to array of additional properties*/
+ XCharStruct min_bounds; /* minimum bounds over all existing char*/
+ XCharStruct max_bounds; /* maximum bounds over all existing char*/
+ XCharStruct *per_char; /* first_char to last_char information */
+ int ascent; /* log. extent above baseline for spacing */
+ int descent; /* log. descent below baseline for spacing */
+} XFontStruct;
+
+/*
+ * PolyText routines take these as arguments.
+ */
+typedef struct {
+ char *chars; /* pointer to string */
+ int nchars; /* number of characters */
+ int delta; /* delta between strings */
+ Font font; /* font to print it in, None don't change */
+} XTextItem;
+
+typedef struct { /* normal 16 bit characters are two bytes */
+ unsigned char byte1;
+ unsigned char byte2;
+} XChar2b;
+
+typedef struct {
+ XChar2b *chars; /* two byte characters */
+ int nchars; /* number of characters */
+ int delta; /* delta between strings */
+ Font font; /* font to print it in, None don't change */
+} XTextItem16;
+
+
+typedef union { Display *display;
+ GC gc;
+ Visual *visual;
+ Screen *screen;
+ ScreenFormat *pixmap_format;
+ XFontStruct *font; } XEDataObject;
+
+typedef struct {
+ XRectangle max_ink_extent;
+ XRectangle max_logical_extent;
+} XFontSetExtents;
+
+typedef struct _XFontSet *XFontSet;
+
+typedef struct {
+ char *chars;
+ int nchars;
+ int delta;
+ XFontSet font_set;
+} XmbTextItem;
+
+typedef struct {
+ wchar_t *chars;
+ int nchars;
+ int delta;
+ XFontSet font_set;
+} XwcTextItem;
+
+typedef void (*XIMProc)();
+
+typedef struct _XIM *XIM;
+typedef struct _XIC *XIC;
+
+typedef unsigned long XIMStyle;
+
+typedef struct {
+ unsigned short count_styles;
+ XIMStyle *supported_styles;
+} XIMStyles;
+
+#define XIMPreeditArea 0x0001L
+#define XIMPreeditCallbacks 0x0002L
+#define XIMPreeditPosition 0x0004L
+#define XIMPreeditNothing 0x0008L
+#define XIMPreeditNone 0x0010L
+#define XIMStatusArea 0x0100L
+#define XIMStatusCallbacks 0x0200L
+#define XIMStatusNothing 0x0400L
+#define XIMStatusNone 0x0800L
+
+#define XNVaNestedList "XNVaNestedList"
+#define XNClientWindow "clientWindow"
+#define XNInputStyle "inputStyle"
+#define XNFocusWindow "focusWindow"
+#define XNResourceName "resourceName"
+#define XNResourceClass "resourceClass"
+#define XNGeometryCallback "geometryCallback"
+#define XNFilterEvents "filterEvents"
+#define XNPreeditStartCallback "preeditStartCallback"
+#define XNPreeditDoneCallback "preeditDoneCallback"
+#define XNPreeditDrawCallback "preeditDrawCallback"
+#define XNPreeditCaretCallback "preeditCaretCallback"
+#define XNPreeditAttributes "preeditAttributes"
+#define XNStatusStartCallback "statusStartCallback"
+#define XNStatusDoneCallback "statusDoneCallback"
+#define XNStatusDrawCallback "statusDrawCallback"
+#define XNStatusAttributes "statusAttributes"
+#define XNArea "area"
+#define XNAreaNeeded "areaNeeded"
+#define XNSpotLocation "spotLocation"
+#define XNColormap "colorMap"
+#define XNStdColormap "stdColorMap"
+#define XNForeground "foreground"
+#define XNBackground "background"
+#define XNBackgroundPixmap "backgroundPixmap"
+#define XNFontSet "fontSet"
+#define XNLineSpace "lineSpace"
+#define XNCursor "cursor"
+
+#define XBufferOverflow -1
+#define XLookupNone 1
+#define XLookupChars 2
+#define XLookupKeySym 3
+#define XLookupBoth 4
+
+#if NeedFunctionPrototypes
+typedef void *XVaNestedList;
+#else
+typedef XPointer XVaNestedList;
+#endif
+
+typedef struct {
+ XPointer client_data;
+ XIMProc callback;
+} XIMCallback;
+
+typedef unsigned long XIMFeedback;
+
+#define XIMReverse 1
+#define XIMUnderline (1<<1)
+#define XIMHighlight (1<<2)
+#define XIMPrimary (1<<5)
+#define XIMSecondary (1<<6)
+#define XIMTertiary (1<<7)
+
+typedef struct _XIMText {
+ unsigned short length;
+ XIMFeedback *feedback;
+ Bool encoding_is_wchar;
+ union {
+ char *multi_byte;
+ wchar_t *wide_char;
+ } string;
+} XIMText;
+
+typedef struct _XIMPreeditDrawCallbackStruct {
+ int caret; /* Cursor offset within pre-edit string */
+ int chg_first; /* Starting change position */
+ int chg_length; /* Length of the change in character count */
+ XIMText *text;
+} XIMPreeditDrawCallbackStruct;
+
+typedef enum {
+ XIMForwardChar, XIMBackwardChar,
+ XIMForwardWord, XIMBackwardWord,
+ XIMCaretUp, XIMCaretDown,
+ XIMNextLine, XIMPreviousLine,
+ XIMLineStart, XIMLineEnd,
+ XIMAbsolutePosition,
+ XIMDontChange
+} XIMCaretDirection;
+
+typedef enum {
+ XIMIsInvisible, /* Disable caret feedback */
+ XIMIsPrimary, /* UI defined caret feedback */
+ XIMIsSecondary /* UI defined caret feedback */
+} XIMCaretStyle;
+
+typedef struct _XIMPreeditCaretCallbackStruct {
+ int position; /* Caret offset within pre-edit string */
+ XIMCaretDirection direction; /* Caret moves direction */
+ XIMCaretStyle style; /* Feedback of the caret */
+} XIMPreeditCaretCallbackStruct;
+
+typedef enum {
+ XIMTextType,
+ XIMBitmapType
+} XIMStatusDataType;
+
+typedef struct _XIMStatusDrawCallbackStruct {
+ XIMStatusDataType type;
+ union {
+ XIMText *text;
+ Pixmap bitmap;
+ } data;
+} XIMStatusDrawCallbackStruct;
+
+typedef int (*XErrorHandler) ( /* WARNING, this type not in Xlib spec */
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XErrorEvent* /* error_event */
+#endif
+);
+
+_XFUNCPROTOBEGIN
+
+
+
+#include "../../../pTk/tkIntXlibDecls.h"
+
+_XFUNCPROTOEND
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Cursor
+#endif
+
+#endif /* _XLIB_H_ */
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h b/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h
new file mode 100644
index 00000000000..af44e0e9c2e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/Xutil.h
@@ -0,0 +1,855 @@
+/* $XConsortium: Xutil.h,v 11.73 91/07/30 16:21:37 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+#ifndef _XUTIL_H_
+#define _XUTIL_H_
+
+/* You must include <X11/Xlib.h> before including this file */
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# define Region XRegion
+#endif
+
+/*
+ * Bitmask returned by XParseGeometry(). Each bit tells if the corresponding
+ * value (x, y, width, height) was found in the parsed string.
+ */
+#define NoValue 0x0000
+#define XValue 0x0001
+#define YValue 0x0002
+#define WidthValue 0x0004
+#define HeightValue 0x0008
+#define AllValues 0x000F
+#define XNegative 0x0010
+#define YNegative 0x0020
+
+/*
+ * new version containing base_width, base_height, and win_gravity fields;
+ * used with WM_NORMAL_HINTS.
+ */
+typedef struct {
+ long flags; /* marks which fields in this structure are defined */
+ int x, y; /* obsolete for new window mgrs, but clients */
+ int width, height; /* should set so old wm's don't mess up */
+ int min_width, min_height;
+ int max_width, max_height;
+ int width_inc, height_inc;
+ struct {
+ int x; /* numerator */
+ int y; /* denominator */
+ } min_aspect, max_aspect;
+ int base_width, base_height; /* added by ICCCM version 1 */
+ int win_gravity; /* added by ICCCM version 1 */
+} XSizeHints;
+
+/*
+ * The next block of definitions are for window manager properties that
+ * clients and applications use for communication.
+ */
+
+/* flags argument in size hints */
+#define USPosition (1L << 0) /* user specified x, y */
+#define USSize (1L << 1) /* user specified width, height */
+
+#define PPosition (1L << 2) /* program specified position */
+#define PSize (1L << 3) /* program specified size */
+#define PMinSize (1L << 4) /* program specified minimum size */
+#define PMaxSize (1L << 5) /* program specified maximum size */
+#define PResizeInc (1L << 6) /* program specified resize increments */
+#define PAspect (1L << 7) /* program specified min and max aspect ratios */
+#define PBaseSize (1L << 8) /* program specified base for incrementing */
+#define PWinGravity (1L << 9) /* program specified window gravity */
+
+/* obsolete */
+#define PAllHints (PPosition|PSize|PMinSize|PMaxSize|PResizeInc|PAspect)
+
+
+
+typedef struct {
+ long flags; /* marks which fields in this structure are defined */
+ Bool input; /* does this application rely on the window manager to
+ get keyboard input? */
+ int initial_state; /* see below */
+ Pixmap icon_pixmap; /* pixmap to be used as icon */
+ Window icon_window; /* window to be used as icon */
+ int icon_x, icon_y; /* initial position of icon */
+ Pixmap icon_mask; /* icon mask bitmap */
+ XID window_group; /* id of related window group */
+ /* this structure may be extended in the future */
+} XWMHints;
+
+/* definition for flags of XWMHints */
+
+#define InputHint (1L << 0)
+#define StateHint (1L << 1)
+#define IconPixmapHint (1L << 2)
+#define IconWindowHint (1L << 3)
+#define IconPositionHint (1L << 4)
+#define IconMaskHint (1L << 5)
+#define WindowGroupHint (1L << 6)
+#define AllHints (InputHint|StateHint|IconPixmapHint|IconWindowHint| \
+IconPositionHint|IconMaskHint|WindowGroupHint)
+
+/* definitions for initial window state */
+#define WithdrawnState 0 /* for windows that are not mapped */
+#define NormalState 1 /* most applications want to start this way */
+#define IconicState 3 /* application wants to start as an icon */
+
+/*
+ * Obsolete states no longer defined by ICCCM
+ */
+#define DontCareState 0 /* don't know or care */
+#define ZoomState 2 /* application wants to start zoomed */
+#define InactiveState 4 /* application believes it is seldom used; */
+ /* some wm's may put it on inactive menu */
+
+
+/*
+ * new structure for manipulating TEXT properties; used with WM_NAME,
+ * WM_ICON_NAME, WM_CLIENT_MACHINE, and WM_COMMAND.
+ */
+typedef struct {
+ unsigned char *value; /* same as Property routines */
+ Atom encoding; /* prop type */
+ int format; /* prop data format: 8, 16, or 32 */
+ unsigned long nitems; /* number of data items in value */
+} XTextProperty;
+
+#define XNoMemory -1
+#define XLocaleNotSupported -2
+#define XConverterNotFound -3
+
+typedef enum {
+ XStringStyle, /* STRING */
+ XCompoundTextStyle, /* COMPOUND_TEXT */
+ XTextStyle, /* text in owner's encoding (current locale)*/
+ XStdICCTextStyle /* STRING, else COMPOUND_TEXT */
+} XICCEncodingStyle;
+
+typedef struct {
+ int min_width, min_height;
+ int max_width, max_height;
+ int width_inc, height_inc;
+} XIconSize;
+
+typedef struct {
+ char *res_name;
+ char *res_class;
+} XClassHint;
+
+/*
+ * These macros are used to give some sugar to the image routines so that
+ * naive people are more comfortable with them.
+ */
+#define XDestroyImage(ximage) \
+ ((*((ximage)->f.destroy_image))((ximage)))
+#define XGetPixel(ximage, x, y) \
+ ((*((ximage)->f.get_pixel))((ximage), (x), (y)))
+#define XPutPixel(ximage, x, y, pixel) \
+ ((*((ximage)->f.put_pixel))((ximage), (x), (y), (pixel)))
+#define XSubImage(ximage, x, y, width, height) \
+ ((*((ximage)->f.sub_image))((ximage), (x), (y), (width), (height)))
+#define XAddPixel(ximage, value) \
+ ((*((ximage)->f.add_pixel))((ximage), (value)))
+
+/*
+ * Compose sequence status structure, used in calling XLookupString.
+ */
+typedef struct _XComposeStatus {
+ XPointer compose_ptr; /* state table pointer */
+ int chars_matched; /* match state */
+} XComposeStatus;
+
+/*
+ * Keysym macros, used on Keysyms to test for classes of symbols
+ */
+#define IsKeypadKey(keysym) \
+ (((unsigned)(keysym) >= XK_KP_Space) && ((unsigned)(keysym) <= XK_KP_Equal))
+
+#define IsCursorKey(keysym) \
+ (((unsigned)(keysym) >= XK_Home) && ((unsigned)(keysym) < XK_Select))
+
+#define IsPFKey(keysym) \
+ (((unsigned)(keysym) >= XK_KP_F1) && ((unsigned)(keysym) <= XK_KP_F4))
+
+#define IsFunctionKey(keysym) \
+ (((unsigned)(keysym) >= XK_F1) && ((unsigned)(keysym) <= XK_F35))
+
+#define IsMiscFunctionKey(keysym) \
+ (((unsigned)(keysym) >= XK_Select) && ((unsigned)(keysym) <= XK_Break))
+
+#define IsModifierKey(keysym) \
+ ((((unsigned)(keysym) >= XK_Shift_L) && ((unsigned)(keysym) <= XK_Hyper_R)) \
+ || ((unsigned)(keysym) == XK_Mode_switch) \
+ || ((unsigned)(keysym) == XK_Num_Lock))
+/*
+ * opaque reference to Region data type
+ */
+typedef struct _XRegion *Region;
+
+/* Return values from XRectInRegion() */
+
+#define RectangleOut 0
+#define RectangleIn 1
+#define RectanglePart 2
+
+
+/*
+ * Information used by the visual utility routines to find desired visual
+ * type from the many visuals a display may support.
+ */
+
+typedef struct {
+ Visual *visual;
+ VisualID visualid;
+ int screen;
+ int depth;
+#if defined(__cplusplus) || defined(c_plusplus)
+ int c_class; /* C++ */
+#else
+ int class;
+#endif
+ unsigned long red_mask;
+ unsigned long green_mask;
+ unsigned long blue_mask;
+ int colormap_size;
+ int bits_per_rgb;
+} XVisualInfo;
+
+#define VisualNoMask 0x0
+#define VisualIDMask 0x1
+#define VisualScreenMask 0x2
+#define VisualDepthMask 0x4
+#define VisualClassMask 0x8
+#define VisualRedMaskMask 0x10
+#define VisualGreenMaskMask 0x20
+#define VisualBlueMaskMask 0x40
+#define VisualColormapSizeMask 0x80
+#define VisualBitsPerRGBMask 0x100
+#define VisualAllMask 0x1FF
+
+/*
+ * This defines a window manager property that clients may use to
+ * share standard color maps of type RGB_COLOR_MAP:
+ */
+typedef struct {
+ Colormap colormap;
+ unsigned long red_max;
+ unsigned long red_mult;
+ unsigned long green_max;
+ unsigned long green_mult;
+ unsigned long blue_max;
+ unsigned long blue_mult;
+ unsigned long base_pixel;
+ VisualID visualid; /* added by ICCCM version 1 */
+ XID killid; /* added by ICCCM version 1 */
+} XStandardColormap;
+
+#define ReleaseByFreeingColormap ((XID) 1L) /* for killid field above */
+
+
+/*
+ * return codes for XReadBitmapFile and XWriteBitmapFile
+ */
+#define BitmapSuccess 0
+#define BitmapOpenFailed 1
+#define BitmapFileInvalid 2
+#define BitmapNoMemory 3
+
+/****************************************************************
+ *
+ * Context Management
+ *
+ ****************************************************************/
+
+
+/* Associative lookup table return codes */
+
+#define XCSUCCESS 0 /* No error. */
+#define XCNOMEM 1 /* Out of memory */
+#define XCNOENT 2 /* No entry in table */
+
+typedef int XContext;
+
+#define XUniqueContext() ((XContext) XrmUniqueQuark())
+#define XStringToContext(string) ((XContext) XrmStringToQuark(string))
+
+_XFUNCPROTOBEGIN
+
+/* The following declarations are alphabetized. */
+
+extern XClassHint *XAllocClassHint (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XIconSize *XAllocIconSize (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XSizeHints *XAllocSizeHints (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XStandardColormap *XAllocStandardColormap (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern XWMHints *XAllocWMHints (
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern void XClipBox(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ XRectangle* /* rect_return */
+#endif
+);
+
+extern Region XCreateRegion(
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern char *XDefaultString(
+#if NeedFunctionPrototypes
+ void
+#endif
+);
+
+extern int XDeleteContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */
+#endif
+);
+
+extern void XDestroyRegion(
+#if NeedFunctionPrototypes
+ Region /* r */
+#endif
+);
+
+extern void XEmptyRegion(
+#if NeedFunctionPrototypes
+ Region /* r */
+#endif
+);
+
+extern void XEqualRegion(
+#if NeedFunctionPrototypes
+ Region /* r1 */,
+ Region /* r2 */
+#endif
+);
+
+extern int XFindContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */,
+ XPointer* /* data_return */
+#endif
+);
+
+extern int XGetClassHint(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XClassHint* /* class_hints_return */
+#endif
+);
+
+extern int XGetIconSizes(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XIconSize** /* size_list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XGetNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */
+#endif
+);
+
+extern int XGetRGBColormaps(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap** /* stdcmap_return */,
+ int* /* count_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetStandardColormap(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* colormap_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* window */,
+ XTextProperty* /* text_prop_return */,
+ Atom /* property */
+#endif
+);
+
+
+extern int XGetWMClientMachine(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern XWMHints *XGetWMHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */
+#endif
+);
+
+extern int XGetWMIconName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XGetWMName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XGetWMNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ long* /* supplied_return */
+#endif
+);
+
+extern int XGetWMSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints_return */,
+ long* /* supplied_return */,
+ Atom /* property */
+#endif
+);
+
+extern int XGetZoomHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* zhints_return */
+#endif
+);
+
+extern void XIntersectRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XLookupString(
+#if NeedFunctionPrototypes
+ XKeyEvent* /* event_struct */,
+ char* /* buffer_return */,
+ int /* bytes_buffer */,
+ KeySym* /* keysym_return */,
+ XComposeStatus* /* status_in_out */
+#endif
+);
+
+extern int XMatchVisualInfo(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ int /* screen */,
+ int /* depth */,
+ int /* class */,
+ XVisualInfo* /* vinfo_return */
+#endif
+);
+
+extern void XOffsetRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* dx */,
+ int /* dy */
+#endif
+);
+
+extern Bool XPointInRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* x */,
+ int /* y */
+#endif
+);
+
+extern Region XPolygonRegion(
+#if NeedFunctionPrototypes
+ XPoint* /* points */,
+ int /* n */,
+ int /* fill_rule */
+#endif
+);
+
+extern int XRectInRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* x */,
+ int /* y */,
+ unsigned int /* width */,
+ unsigned int /* height */
+#endif
+);
+
+extern int XSaveContext(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XID /* rid */,
+ XContext /* context */,
+ _Xconst char* /* data */
+#endif
+);
+
+extern void XSetClassHint(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XSetIconSizes(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XIconSize* /* size_list */,
+ int /* count */
+#endif
+);
+
+extern void XSetNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetRGBColormaps(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* stdcmaps */,
+ int /* count */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetStandardProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ _Xconst char* /* window_name */,
+ _Xconst char* /* icon_name */,
+ Pixmap /* icon_pixmap */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetWMHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XWMHints* /* wm_hints */
+#endif
+);
+
+extern void XSetWMIconName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */
+#endif
+);
+
+extern void XSetWMName(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* text_prop */
+#endif
+);
+
+extern void XSetWMNormalHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */
+#endif
+);
+
+extern void XSetWMProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XTextProperty* /* window_name */,
+ XTextProperty* /* icon_name */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* normal_hints */,
+ XWMHints* /* wm_hints */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XmbSetWMProperties(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ _Xconst char* /* window_name */,
+ _Xconst char* /* icon_name */,
+ char** /* argv */,
+ int /* argc */,
+ XSizeHints* /* normal_hints */,
+ XWMHints* /* wm_hints */,
+ XClassHint* /* class_hints */
+#endif
+);
+
+extern void XSetWMSizeHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* hints */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetRegion(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ GC /* gc */,
+ Region /* r */
+#endif
+);
+
+extern void XSetStandardColormap(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XStandardColormap* /* colormap */,
+ Atom /* property */
+#endif
+);
+
+extern void XSetZoomHints(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ Window /* w */,
+ XSizeHints* /* zhints */
+#endif
+);
+
+extern void XShrinkRegion(
+#if NeedFunctionPrototypes
+ Region /* r */,
+ int /* dx */,
+ int /* dy */
+#endif
+);
+
+extern void XSubtractRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XmbTextListToTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ char** /* list */,
+ int /* count */,
+ XICCEncodingStyle /* style */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern int XwcTextListToTextProperty(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ wchar_t** /* list */,
+ int /* count */,
+ XICCEncodingStyle /* style */,
+ XTextProperty* /* text_prop_return */
+#endif
+);
+
+extern void XwcFreeStringList(
+#if NeedFunctionPrototypes
+ wchar_t** /* list */
+#endif
+);
+
+extern int XTextPropertyToStringList(
+#if NeedFunctionPrototypes
+ XTextProperty* /* text_prop */,
+ char*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XmbTextPropertyToTextList(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XTextProperty* /* text_prop */,
+ char*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern int XwcTextPropertyToTextList(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ XTextProperty* /* text_prop */,
+ wchar_t*** /* list_return */,
+ int* /* count_return */
+#endif
+);
+
+extern void XUnionRectWithRegion(
+#if NeedFunctionPrototypes
+ XRectangle* /* rectangle */,
+ Region /* src_region */,
+ Region /* dest_region_return */
+#endif
+);
+
+extern void XUnionRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+extern int XWMGeometry(
+#if NeedFunctionPrototypes
+ Display* /* display */,
+ int /* screen_number */,
+ _Xconst char* /* user_geometry */,
+ _Xconst char* /* default_geometry */,
+ unsigned int /* border_width */,
+ XSizeHints* /* hints */,
+ int* /* x_return */,
+ int* /* y_return */,
+ int* /* width_return */,
+ int* /* height_return */,
+ int* /* gravity_return */
+#endif
+);
+
+extern void XXorRegion(
+#if NeedFunctionPrototypes
+ Region /* sra */,
+ Region /* srb */,
+ Region /* dr_return */
+#endif
+);
+
+_XFUNCPROTOEND
+
+#if defined(MAC_TCL) || defined(MAC_OSX_TK)
+# undef Region
+#endif
+
+#endif /* _XUTIL_H_ */
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h b/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h
new file mode 100644
index 00000000000..617274fa806
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/cursorfont.h
@@ -0,0 +1,79 @@
+/* $XConsortium: cursorfont.h,v 1.2 88/09/06 16:44:27 jim Exp $ */
+#define XC_num_glyphs 154
+#define XC_X_cursor 0
+#define XC_arrow 2
+#define XC_based_arrow_down 4
+#define XC_based_arrow_up 6
+#define XC_boat 8
+#define XC_bogosity 10
+#define XC_bottom_left_corner 12
+#define XC_bottom_right_corner 14
+#define XC_bottom_side 16
+#define XC_bottom_tee 18
+#define XC_box_spiral 20
+#define XC_center_ptr 22
+#define XC_circle 24
+#define XC_clock 26
+#define XC_coffee_mug 28
+#define XC_cross 30
+#define XC_cross_reverse 32
+#define XC_crosshair 34
+#define XC_diamond_cross 36
+#define XC_dot 38
+#define XC_dotbox 40
+#define XC_double_arrow 42
+#define XC_draft_large 44
+#define XC_draft_small 46
+#define XC_draped_box 48
+#define XC_exchange 50
+#define XC_fleur 52
+#define XC_gobbler 54
+#define XC_gumby 56
+#define XC_hand1 58
+#define XC_hand2 60
+#define XC_heart 62
+#define XC_icon 64
+#define XC_iron_cross 66
+#define XC_left_ptr 68
+#define XC_left_side 70
+#define XC_left_tee 72
+#define XC_leftbutton 74
+#define XC_ll_angle 76
+#define XC_lr_angle 78
+#define XC_man 80
+#define XC_middlebutton 82
+#define XC_mouse 84
+#define XC_pencil 86
+#define XC_pirate 88
+#define XC_plus 90
+#define XC_question_arrow 92
+#define XC_right_ptr 94
+#define XC_right_side 96
+#define XC_right_tee 98
+#define XC_rightbutton 100
+#define XC_rtl_logo 102
+#define XC_sailboat 104
+#define XC_sb_down_arrow 106
+#define XC_sb_h_double_arrow 108
+#define XC_sb_left_arrow 110
+#define XC_sb_right_arrow 112
+#define XC_sb_up_arrow 114
+#define XC_sb_v_double_arrow 116
+#define XC_shuttle 118
+#define XC_sizing 120
+#define XC_spider 122
+#define XC_spraycan 124
+#define XC_star 126
+#define XC_target 128
+#define XC_tcross 130
+#define XC_top_left_arrow 132
+#define XC_top_left_corner 134
+#define XC_top_right_corner 136
+#define XC_top_side 138
+#define XC_top_tee 140
+#define XC_trek 142
+#define XC_ul_angle 144
+#define XC_umbrella 146
+#define XC_ur_angle 148
+#define XC_watch 150
+#define XC_xterm 152
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h b/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h
new file mode 100644
index 00000000000..027afe08d5f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/keysym.h
@@ -0,0 +1,39 @@
+/* $XConsortium: keysym.h,v 1.13 91/03/13 20:09:49 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+/* default keysyms */
+#define XK_MISCELLANY
+#define XK_LATIN1
+#define XK_LATIN2
+#define XK_LATIN3
+#define XK_LATIN4
+#define XK_GREEK
+
+#ifdef MAC_TCL
+#include <keysymdef.h>
+#else
+#include <X11/keysymdef.h>
+#endif
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h b/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h
new file mode 100644
index 00000000000..b22d41b3385
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/keysymdef.h
@@ -0,0 +1,1169 @@
+/* $XConsortium: keysymdef.h,v 1.15 93/04/02 10:57:36 rws Exp $ */
+
+/***********************************************************
+Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+ All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation, and that the names of Digital or MIT not be
+used in advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+******************************************************************/
+
+#define XK_VoidSymbol 0xFFFFFF /* void symbol */
+
+#ifdef XK_MISCELLANY
+/*
+ * TTY Functions, cleverly chosen to map to ascii, for convenience of
+ * programming, but could have been arbitrary (at the cost of lookup
+ * tables in client code.
+ */
+
+#define XK_BackSpace 0xFF08 /* back space, back char */
+#define XK_Tab 0xFF09
+#define XK_Linefeed 0xFF0A /* Linefeed, LF */
+#define XK_Clear 0xFF0B
+#define XK_Return 0xFF0D /* Return, enter */
+#define XK_Pause 0xFF13 /* Pause, hold */
+#define XK_Scroll_Lock 0xFF14
+#define XK_Sys_Req 0xFF15
+#define XK_Escape 0xFF1B
+#define XK_Delete 0xFFFF /* Delete, rubout */
+
+
+
+/* International & multi-key character composition */
+
+#define XK_Multi_key 0xFF20 /* Multi-key character compose */
+
+/* Japanese keyboard support */
+
+#define XK_Kanji 0xFF21 /* Kanji, Kanji convert */
+#define XK_Muhenkan 0xFF22 /* Cancel Conversion */
+#define XK_Henkan_Mode 0xFF23 /* Start/Stop Conversion */
+#define XK_Henkan 0xFF23 /* Alias for Henkan_Mode */
+#define XK_Romaji 0xFF24 /* to Romaji */
+#define XK_Hiragana 0xFF25 /* to Hiragana */
+#define XK_Katakana 0xFF26 /* to Katakana */
+#define XK_Hiragana_Katakana 0xFF27 /* Hiragana/Katakana toggle */
+#define XK_Zenkaku 0xFF28 /* to Zenkaku */
+#define XK_Hankaku 0xFF29 /* to Hankaku */
+#define XK_Zenkaku_Hankaku 0xFF2A /* Zenkaku/Hankaku toggle */
+#define XK_Touroku 0xFF2B /* Add to Dictionary */
+#define XK_Massyo 0xFF2C /* Delete from Dictionary */
+#define XK_Kana_Lock 0xFF2D /* Kana Lock */
+#define XK_Kana_Shift 0xFF2E /* Kana Shift */
+#define XK_Eisu_Shift 0xFF2F /* Alphanumeric Shift */
+#define XK_Eisu_toggle 0xFF30 /* Alphanumeric toggle */
+
+/* Cursor control & motion */
+
+#define XK_Home 0xFF50
+#define XK_Left 0xFF51 /* Move left, left arrow */
+#define XK_Up 0xFF52 /* Move up, up arrow */
+#define XK_Right 0xFF53 /* Move right, right arrow */
+#define XK_Down 0xFF54 /* Move down, down arrow */
+#define XK_Prior 0xFF55 /* Prior, previous */
+#define XK_Page_Up 0xFF55
+#define XK_Next 0xFF56 /* Next */
+#define XK_Page_Down 0xFF56
+#define XK_End 0xFF57 /* EOL */
+#define XK_Begin 0xFF58 /* BOL */
+
+/* Special Windows keyboard keys */
+
+#define XK_Win_L 0xFF5B /* Left-hand Windows */
+#define XK_Win_R 0xFF5C /* Right-hand Windows */
+#define XK_App 0xFF5D /* Menu key */
+
+/* Misc Functions */
+
+#define XK_Select 0xFF60 /* Select, mark */
+#define XK_Print 0xFF61
+#define XK_Execute 0xFF62 /* Execute, run, do */
+#define XK_Insert 0xFF63 /* Insert, insert here */
+#define XK_Undo 0xFF65 /* Undo, oops */
+#define XK_Redo 0xFF66 /* redo, again */
+#define XK_Menu 0xFF67
+#define XK_Find 0xFF68 /* Find, search */
+#define XK_Cancel 0xFF69 /* Cancel, stop, abort, exit */
+#define XK_Help 0xFF6A /* Help, ? */
+#define XK_Break 0xFF6B
+#define XK_Mode_switch 0xFF7E /* Character set switch */
+#define XK_script_switch 0xFF7E /* Alias for mode_switch */
+#define XK_Num_Lock 0xFF7F
+
+/* Keypad Functions, keypad numbers cleverly chosen to map to ascii */
+
+#define XK_KP_Space 0xFF80 /* space */
+#define XK_KP_Tab 0xFF89
+#define XK_KP_Enter 0xFF8D /* enter */
+#define XK_KP_F1 0xFF91 /* PF1, KP_A, ... */
+#define XK_KP_F2 0xFF92
+#define XK_KP_F3 0xFF93
+#define XK_KP_F4 0xFF94
+#define XK_KP_Home 0xFF95
+#define XK_KP_Left 0xFF96
+#define XK_KP_Up 0xFF97
+#define XK_KP_Right 0xFF98
+#define XK_KP_Down 0xFF99
+#define XK_KP_Prior 0xFF9A
+#define XK_KP_Page_Up 0xFF9A
+#define XK_KP_Next 0xFF9B
+#define XK_KP_Page_Down 0xFF9B
+#define XK_KP_End 0xFF9C
+#define XK_KP_Begin 0xFF9D
+#define XK_KP_Insert 0xFF9E
+#define XK_KP_Delete 0xFF9F
+#define XK_KP_Equal 0xFFBD /* equals */
+#define XK_KP_Multiply 0xFFAA
+#define XK_KP_Add 0xFFAB
+#define XK_KP_Separator 0xFFAC /* separator, often comma */
+#define XK_KP_Subtract 0xFFAD
+#define XK_KP_Decimal 0xFFAE
+#define XK_KP_Divide 0xFFAF
+
+#define XK_KP_0 0xFFB0
+#define XK_KP_1 0xFFB1
+#define XK_KP_2 0xFFB2
+#define XK_KP_3 0xFFB3
+#define XK_KP_4 0xFFB4
+#define XK_KP_5 0xFFB5
+#define XK_KP_6 0xFFB6
+#define XK_KP_7 0xFFB7
+#define XK_KP_8 0xFFB8
+#define XK_KP_9 0xFFB9
+
+
+
+/*
+ * Auxilliary Functions; note the duplicate definitions for left and right
+ * function keys; Sun keyboards and a few other manufactures have such
+ * function key groups on the left and/or right sides of the keyboard.
+ * We've not found a keyboard with more than 35 function keys total.
+ */
+
+#define XK_F1 0xFFBE
+#define XK_F2 0xFFBF
+#define XK_F3 0xFFC0
+#define XK_F4 0xFFC1
+#define XK_F5 0xFFC2
+#define XK_F6 0xFFC3
+#define XK_F7 0xFFC4
+#define XK_F8 0xFFC5
+#define XK_F9 0xFFC6
+#define XK_F10 0xFFC7
+#define XK_F11 0xFFC8
+#define XK_L1 0xFFC8
+#define XK_F12 0xFFC9
+#define XK_L2 0xFFC9
+#define XK_F13 0xFFCA
+#define XK_L3 0xFFCA
+#define XK_F14 0xFFCB
+#define XK_L4 0xFFCB
+#define XK_F15 0xFFCC
+#define XK_L5 0xFFCC
+#define XK_F16 0xFFCD
+#define XK_L6 0xFFCD
+#define XK_F17 0xFFCE
+#define XK_L7 0xFFCE
+#define XK_F18 0xFFCF
+#define XK_L8 0xFFCF
+#define XK_F19 0xFFD0
+#define XK_L9 0xFFD0
+#define XK_F20 0xFFD1
+#define XK_L10 0xFFD1
+#define XK_F21 0xFFD2
+#define XK_R1 0xFFD2
+#define XK_F22 0xFFD3
+#define XK_R2 0xFFD3
+#define XK_F23 0xFFD4
+#define XK_R3 0xFFD4
+#define XK_F24 0xFFD5
+#define XK_R4 0xFFD5
+#define XK_F25 0xFFD6
+#define XK_R5 0xFFD6
+#define XK_F26 0xFFD7
+#define XK_R6 0xFFD7
+#define XK_F27 0xFFD8
+#define XK_R7 0xFFD8
+#define XK_F28 0xFFD9
+#define XK_R8 0xFFD9
+#define XK_F29 0xFFDA
+#define XK_R9 0xFFDA
+#define XK_F30 0xFFDB
+#define XK_R10 0xFFDB
+#define XK_F31 0xFFDC
+#define XK_R11 0xFFDC
+#define XK_F32 0xFFDD
+#define XK_R12 0xFFDD
+#define XK_F33 0xFFDE
+#define XK_R13 0xFFDE
+#define XK_F34 0xFFDF
+#define XK_R14 0xFFDF
+#define XK_F35 0xFFE0
+#define XK_R15 0xFFE0
+
+/* Modifiers */
+
+#define XK_Shift_L 0xFFE1 /* Left shift */
+#define XK_Shift_R 0xFFE2 /* Right shift */
+#define XK_Control_L 0xFFE3 /* Left control */
+#define XK_Control_R 0xFFE4 /* Right control */
+#define XK_Caps_Lock 0xFFE5 /* Caps lock */
+#define XK_Shift_Lock 0xFFE6 /* Shift lock */
+
+#define XK_Meta_L 0xFFE7 /* Left meta */
+#define XK_Meta_R 0xFFE8 /* Right meta */
+#define XK_Alt_L 0xFFE9 /* Left alt */
+#define XK_Alt_R 0xFFEA /* Right alt */
+#define XK_Super_L 0xFFEB /* Left super */
+#define XK_Super_R 0xFFEC /* Right super */
+#define XK_Hyper_L 0xFFED /* Left hyper */
+#define XK_Hyper_R 0xFFEE /* Right hyper */
+#endif /* XK_MISCELLANY */
+
+/*
+ * Latin 1
+ * Byte 3 = 0
+ */
+#ifdef XK_LATIN1
+#define XK_space 0x020
+#define XK_exclam 0x021
+#define XK_quotedbl 0x022
+#define XK_numbersign 0x023
+#define XK_dollar 0x024
+#define XK_percent 0x025
+#define XK_ampersand 0x026
+#define XK_apostrophe 0x027
+#define XK_quoteright 0x027 /* deprecated */
+#define XK_parenleft 0x028
+#define XK_parenright 0x029
+#define XK_asterisk 0x02a
+#define XK_plus 0x02b
+#define XK_comma 0x02c
+#define XK_minus 0x02d
+#define XK_period 0x02e
+#define XK_slash 0x02f
+#define XK_0 0x030
+#define XK_1 0x031
+#define XK_2 0x032
+#define XK_3 0x033
+#define XK_4 0x034
+#define XK_5 0x035
+#define XK_6 0x036
+#define XK_7 0x037
+#define XK_8 0x038
+#define XK_9 0x039
+#define XK_colon 0x03a
+#define XK_semicolon 0x03b
+#define XK_less 0x03c
+#define XK_equal 0x03d
+#define XK_greater 0x03e
+#define XK_question 0x03f
+#define XK_at 0x040
+#define XK_A 0x041
+#define XK_B 0x042
+#define XK_C 0x043
+#define XK_D 0x044
+#define XK_E 0x045
+#define XK_F 0x046
+#define XK_G 0x047
+#define XK_H 0x048
+#define XK_I 0x049
+#define XK_J 0x04a
+#define XK_K 0x04b
+#define XK_L 0x04c
+#define XK_M 0x04d
+#define XK_N 0x04e
+#define XK_O 0x04f
+#define XK_P 0x050
+#define XK_Q 0x051
+#define XK_R 0x052
+#define XK_S 0x053
+#define XK_T 0x054
+#define XK_U 0x055
+#define XK_V 0x056
+#define XK_W 0x057
+#define XK_X 0x058
+#define XK_Y 0x059
+#define XK_Z 0x05a
+#define XK_bracketleft 0x05b
+#define XK_backslash 0x05c
+#define XK_bracketright 0x05d
+#define XK_asciicircum 0x05e
+#define XK_underscore 0x05f
+#define XK_grave 0x060
+#define XK_quoteleft 0x060 /* deprecated */
+#define XK_a 0x061
+#define XK_b 0x062
+#define XK_c 0x063
+#define XK_d 0x064
+#define XK_e 0x065
+#define XK_f 0x066
+#define XK_g 0x067
+#define XK_h 0x068
+#define XK_i 0x069
+#define XK_j 0x06a
+#define XK_k 0x06b
+#define XK_l 0x06c
+#define XK_m 0x06d
+#define XK_n 0x06e
+#define XK_o 0x06f
+#define XK_p 0x070
+#define XK_q 0x071
+#define XK_r 0x072
+#define XK_s 0x073
+#define XK_t 0x074
+#define XK_u 0x075
+#define XK_v 0x076
+#define XK_w 0x077
+#define XK_x 0x078
+#define XK_y 0x079
+#define XK_z 0x07a
+#define XK_braceleft 0x07b
+#define XK_bar 0x07c
+#define XK_braceright 0x07d
+#define XK_asciitilde 0x07e
+
+#define XK_nobreakspace 0x0a0
+#define XK_exclamdown 0x0a1
+#define XK_cent 0x0a2
+#define XK_sterling 0x0a3
+#define XK_currency 0x0a4
+#define XK_yen 0x0a5
+#define XK_brokenbar 0x0a6
+#define XK_section 0x0a7
+#define XK_diaeresis 0x0a8
+#define XK_copyright 0x0a9
+#define XK_ordfeminine 0x0aa
+#define XK_guillemotleft 0x0ab /* left angle quotation mark */
+#define XK_notsign 0x0ac
+#define XK_hyphen 0x0ad
+#define XK_registered 0x0ae
+#define XK_macron 0x0af
+#define XK_degree 0x0b0
+#define XK_plusminus 0x0b1
+#define XK_twosuperior 0x0b2
+#define XK_threesuperior 0x0b3
+#define XK_acute 0x0b4
+#define XK_mu 0x0b5
+#define XK_paragraph 0x0b6
+#define XK_periodcentered 0x0b7
+#define XK_cedilla 0x0b8
+#define XK_onesuperior 0x0b9
+#define XK_masculine 0x0ba
+#define XK_guillemotright 0x0bb /* right angle quotation mark */
+#define XK_onequarter 0x0bc
+#define XK_onehalf 0x0bd
+#define XK_threequarters 0x0be
+#define XK_questiondown 0x0bf
+#define XK_Agrave 0x0c0
+#define XK_Aacute 0x0c1
+#define XK_Acircumflex 0x0c2
+#define XK_Atilde 0x0c3
+#define XK_Adiaeresis 0x0c4
+#define XK_Aring 0x0c5
+#define XK_AE 0x0c6
+#define XK_Ccedilla 0x0c7
+#define XK_Egrave 0x0c8
+#define XK_Eacute 0x0c9
+#define XK_Ecircumflex 0x0ca
+#define XK_Ediaeresis 0x0cb
+#define XK_Igrave 0x0cc
+#define XK_Iacute 0x0cd
+#define XK_Icircumflex 0x0ce
+#define XK_Idiaeresis 0x0cf
+#define XK_ETH 0x0d0
+#define XK_Eth 0x0d0 /* deprecated */
+#define XK_Ntilde 0x0d1
+#define XK_Ograve 0x0d2
+#define XK_Oacute 0x0d3
+#define XK_Ocircumflex 0x0d4
+#define XK_Otilde 0x0d5
+#define XK_Odiaeresis 0x0d6
+#define XK_multiply 0x0d7
+#define XK_Ooblique 0x0d8
+#define XK_Ugrave 0x0d9
+#define XK_Uacute 0x0da
+#define XK_Ucircumflex 0x0db
+#define XK_Udiaeresis 0x0dc
+#define XK_Yacute 0x0dd
+#define XK_THORN 0x0de
+#define XK_Thorn 0x0de /* deprecated */
+#define XK_ssharp 0x0df
+#define XK_agrave 0x0e0
+#define XK_aacute 0x0e1
+#define XK_acircumflex 0x0e2
+#define XK_atilde 0x0e3
+#define XK_adiaeresis 0x0e4
+#define XK_aring 0x0e5
+#define XK_ae 0x0e6
+#define XK_ccedilla 0x0e7
+#define XK_egrave 0x0e8
+#define XK_eacute 0x0e9
+#define XK_ecircumflex 0x0ea
+#define XK_ediaeresis 0x0eb
+#define XK_igrave 0x0ec
+#define XK_iacute 0x0ed
+#define XK_icircumflex 0x0ee
+#define XK_idiaeresis 0x0ef
+#define XK_eth 0x0f0
+#define XK_ntilde 0x0f1
+#define XK_ograve 0x0f2
+#define XK_oacute 0x0f3
+#define XK_ocircumflex 0x0f4
+#define XK_otilde 0x0f5
+#define XK_odiaeresis 0x0f6
+#define XK_division 0x0f7
+#define XK_oslash 0x0f8
+#define XK_ugrave 0x0f9
+#define XK_uacute 0x0fa
+#define XK_ucircumflex 0x0fb
+#define XK_udiaeresis 0x0fc
+#define XK_yacute 0x0fd
+#define XK_thorn 0x0fe
+#define XK_ydiaeresis 0x0ff
+#endif /* XK_LATIN1 */
+
+/*
+ * Latin 2
+ * Byte 3 = 1
+ */
+
+#ifdef XK_LATIN2
+#define XK_Aogonek 0x1a1
+#define XK_breve 0x1a2
+#define XK_Lstroke 0x1a3
+#define XK_Lcaron 0x1a5
+#define XK_Sacute 0x1a6
+#define XK_Scaron 0x1a9
+#define XK_Scedilla 0x1aa
+#define XK_Tcaron 0x1ab
+#define XK_Zacute 0x1ac
+#define XK_Zcaron 0x1ae
+#define XK_Zabovedot 0x1af
+#define XK_aogonek 0x1b1
+#define XK_ogonek 0x1b2
+#define XK_lstroke 0x1b3
+#define XK_lcaron 0x1b5
+#define XK_sacute 0x1b6
+#define XK_caron 0x1b7
+#define XK_scaron 0x1b9
+#define XK_scedilla 0x1ba
+#define XK_tcaron 0x1bb
+#define XK_zacute 0x1bc
+#define XK_doubleacute 0x1bd
+#define XK_zcaron 0x1be
+#define XK_zabovedot 0x1bf
+#define XK_Racute 0x1c0
+#define XK_Abreve 0x1c3
+#define XK_Lacute 0x1c5
+#define XK_Cacute 0x1c6
+#define XK_Ccaron 0x1c8
+#define XK_Eogonek 0x1ca
+#define XK_Ecaron 0x1cc
+#define XK_Dcaron 0x1cf
+#define XK_Dstroke 0x1d0
+#define XK_Nacute 0x1d1
+#define XK_Ncaron 0x1d2
+#define XK_Odoubleacute 0x1d5
+#define XK_Rcaron 0x1d8
+#define XK_Uring 0x1d9
+#define XK_Udoubleacute 0x1db
+#define XK_Tcedilla 0x1de
+#define XK_racute 0x1e0
+#define XK_abreve 0x1e3
+#define XK_lacute 0x1e5
+#define XK_cacute 0x1e6
+#define XK_ccaron 0x1e8
+#define XK_eogonek 0x1ea
+#define XK_ecaron 0x1ec
+#define XK_dcaron 0x1ef
+#define XK_dstroke 0x1f0
+#define XK_nacute 0x1f1
+#define XK_ncaron 0x1f2
+#define XK_odoubleacute 0x1f5
+#define XK_udoubleacute 0x1fb
+#define XK_rcaron 0x1f8
+#define XK_uring 0x1f9
+#define XK_tcedilla 0x1fe
+#define XK_abovedot 0x1ff
+#endif /* XK_LATIN2 */
+
+/*
+ * Latin 3
+ * Byte 3 = 2
+ */
+
+#ifdef XK_LATIN3
+#define XK_Hstroke 0x2a1
+#define XK_Hcircumflex 0x2a6
+#define XK_Iabovedot 0x2a9
+#define XK_Gbreve 0x2ab
+#define XK_Jcircumflex 0x2ac
+#define XK_hstroke 0x2b1
+#define XK_hcircumflex 0x2b6
+#define XK_idotless 0x2b9
+#define XK_gbreve 0x2bb
+#define XK_jcircumflex 0x2bc
+#define XK_Cabovedot 0x2c5
+#define XK_Ccircumflex 0x2c6
+#define XK_Gabovedot 0x2d5
+#define XK_Gcircumflex 0x2d8
+#define XK_Ubreve 0x2dd
+#define XK_Scircumflex 0x2de
+#define XK_cabovedot 0x2e5
+#define XK_ccircumflex 0x2e6
+#define XK_gabovedot 0x2f5
+#define XK_gcircumflex 0x2f8
+#define XK_ubreve 0x2fd
+#define XK_scircumflex 0x2fe
+#endif /* XK_LATIN3 */
+
+
+/*
+ * Latin 4
+ * Byte 3 = 3
+ */
+
+#ifdef XK_LATIN4
+#define XK_kra 0x3a2
+#define XK_kappa 0x3a2 /* deprecated */
+#define XK_Rcedilla 0x3a3
+#define XK_Itilde 0x3a5
+#define XK_Lcedilla 0x3a6
+#define XK_Emacron 0x3aa
+#define XK_Gcedilla 0x3ab
+#define XK_Tslash 0x3ac
+#define XK_rcedilla 0x3b3
+#define XK_itilde 0x3b5
+#define XK_lcedilla 0x3b6
+#define XK_emacron 0x3ba
+#define XK_gcedilla 0x3bb
+#define XK_tslash 0x3bc
+#define XK_ENG 0x3bd
+#define XK_eng 0x3bf
+#define XK_Amacron 0x3c0
+#define XK_Iogonek 0x3c7
+#define XK_Eabovedot 0x3cc
+#define XK_Imacron 0x3cf
+#define XK_Ncedilla 0x3d1
+#define XK_Omacron 0x3d2
+#define XK_Kcedilla 0x3d3
+#define XK_Uogonek 0x3d9
+#define XK_Utilde 0x3dd
+#define XK_Umacron 0x3de
+#define XK_amacron 0x3e0
+#define XK_iogonek 0x3e7
+#define XK_eabovedot 0x3ec
+#define XK_imacron 0x3ef
+#define XK_ncedilla 0x3f1
+#define XK_omacron 0x3f2
+#define XK_kcedilla 0x3f3
+#define XK_uogonek 0x3f9
+#define XK_utilde 0x3fd
+#define XK_umacron 0x3fe
+#endif /* XK_LATIN4 */
+
+/*
+ * Katakana
+ * Byte 3 = 4
+ */
+
+#ifdef XK_KATAKANA
+#define XK_overline 0x47e
+#define XK_kana_fullstop 0x4a1
+#define XK_kana_openingbracket 0x4a2
+#define XK_kana_closingbracket 0x4a3
+#define XK_kana_comma 0x4a4
+#define XK_kana_conjunctive 0x4a5
+#define XK_kana_middledot 0x4a5 /* deprecated */
+#define XK_kana_WO 0x4a6
+#define XK_kana_a 0x4a7
+#define XK_kana_i 0x4a8
+#define XK_kana_u 0x4a9
+#define XK_kana_e 0x4aa
+#define XK_kana_o 0x4ab
+#define XK_kana_ya 0x4ac
+#define XK_kana_yu 0x4ad
+#define XK_kana_yo 0x4ae
+#define XK_kana_tsu 0x4af
+#define XK_kana_tu 0x4af /* deprecated */
+#define XK_prolongedsound 0x4b0
+#define XK_kana_A 0x4b1
+#define XK_kana_I 0x4b2
+#define XK_kana_U 0x4b3
+#define XK_kana_E 0x4b4
+#define XK_kana_O 0x4b5
+#define XK_kana_KA 0x4b6
+#define XK_kana_KI 0x4b7
+#define XK_kana_KU 0x4b8
+#define XK_kana_KE 0x4b9
+#define XK_kana_KO 0x4ba
+#define XK_kana_SA 0x4bb
+#define XK_kana_SHI 0x4bc
+#define XK_kana_SU 0x4bd
+#define XK_kana_SE 0x4be
+#define XK_kana_SO 0x4bf
+#define XK_kana_TA 0x4c0
+#define XK_kana_CHI 0x4c1
+#define XK_kana_TI 0x4c1 /* deprecated */
+#define XK_kana_TSU 0x4c2
+#define XK_kana_TU 0x4c2 /* deprecated */
+#define XK_kana_TE 0x4c3
+#define XK_kana_TO 0x4c4
+#define XK_kana_NA 0x4c5
+#define XK_kana_NI 0x4c6
+#define XK_kana_NU 0x4c7
+#define XK_kana_NE 0x4c8
+#define XK_kana_NO 0x4c9
+#define XK_kana_HA 0x4ca
+#define XK_kana_HI 0x4cb
+#define XK_kana_FU 0x4cc
+#define XK_kana_HU 0x4cc /* deprecated */
+#define XK_kana_HE 0x4cd
+#define XK_kana_HO 0x4ce
+#define XK_kana_MA 0x4cf
+#define XK_kana_MI 0x4d0
+#define XK_kana_MU 0x4d1
+#define XK_kana_ME 0x4d2
+#define XK_kana_MO 0x4d3
+#define XK_kana_YA 0x4d4
+#define XK_kana_YU 0x4d5
+#define XK_kana_YO 0x4d6
+#define XK_kana_RA 0x4d7
+#define XK_kana_RI 0x4d8
+#define XK_kana_RU 0x4d9
+#define XK_kana_RE 0x4da
+#define XK_kana_RO 0x4db
+#define XK_kana_WA 0x4dc
+#define XK_kana_N 0x4dd
+#define XK_voicedsound 0x4de
+#define XK_semivoicedsound 0x4df
+#define XK_kana_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_KATAKANA */
+
+/*
+ * Arabic
+ * Byte 3 = 5
+ */
+
+#ifdef XK_ARABIC
+#define XK_Arabic_comma 0x5ac
+#define XK_Arabic_semicolon 0x5bb
+#define XK_Arabic_question_mark 0x5bf
+#define XK_Arabic_hamza 0x5c1
+#define XK_Arabic_maddaonalef 0x5c2
+#define XK_Arabic_hamzaonalef 0x5c3
+#define XK_Arabic_hamzaonwaw 0x5c4
+#define XK_Arabic_hamzaunderalef 0x5c5
+#define XK_Arabic_hamzaonyeh 0x5c6
+#define XK_Arabic_alef 0x5c7
+#define XK_Arabic_beh 0x5c8
+#define XK_Arabic_tehmarbuta 0x5c9
+#define XK_Arabic_teh 0x5ca
+#define XK_Arabic_theh 0x5cb
+#define XK_Arabic_jeem 0x5cc
+#define XK_Arabic_hah 0x5cd
+#define XK_Arabic_khah 0x5ce
+#define XK_Arabic_dal 0x5cf
+#define XK_Arabic_thal 0x5d0
+#define XK_Arabic_ra 0x5d1
+#define XK_Arabic_zain 0x5d2
+#define XK_Arabic_seen 0x5d3
+#define XK_Arabic_sheen 0x5d4
+#define XK_Arabic_sad 0x5d5
+#define XK_Arabic_dad 0x5d6
+#define XK_Arabic_tah 0x5d7
+#define XK_Arabic_zah 0x5d8
+#define XK_Arabic_ain 0x5d9
+#define XK_Arabic_ghain 0x5da
+#define XK_Arabic_tatweel 0x5e0
+#define XK_Arabic_feh 0x5e1
+#define XK_Arabic_qaf 0x5e2
+#define XK_Arabic_kaf 0x5e3
+#define XK_Arabic_lam 0x5e4
+#define XK_Arabic_meem 0x5e5
+#define XK_Arabic_noon 0x5e6
+#define XK_Arabic_ha 0x5e7
+#define XK_Arabic_heh 0x5e7 /* deprecated */
+#define XK_Arabic_waw 0x5e8
+#define XK_Arabic_alefmaksura 0x5e9
+#define XK_Arabic_yeh 0x5ea
+#define XK_Arabic_fathatan 0x5eb
+#define XK_Arabic_dammatan 0x5ec
+#define XK_Arabic_kasratan 0x5ed
+#define XK_Arabic_fatha 0x5ee
+#define XK_Arabic_damma 0x5ef
+#define XK_Arabic_kasra 0x5f0
+#define XK_Arabic_shadda 0x5f1
+#define XK_Arabic_sukun 0x5f2
+#define XK_Arabic_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_ARABIC */
+
+/*
+ * Cyrillic
+ * Byte 3 = 6
+ */
+#ifdef XK_CYRILLIC
+#define XK_Serbian_dje 0x6a1
+#define XK_Macedonia_gje 0x6a2
+#define XK_Cyrillic_io 0x6a3
+#define XK_Ukrainian_ie 0x6a4
+#define XK_Ukranian_je 0x6a4 /* deprecated */
+#define XK_Macedonia_dse 0x6a5
+#define XK_Ukrainian_i 0x6a6
+#define XK_Ukranian_i 0x6a6 /* deprecated */
+#define XK_Ukrainian_yi 0x6a7
+#define XK_Ukranian_yi 0x6a7 /* deprecated */
+#define XK_Cyrillic_je 0x6a8
+#define XK_Serbian_je 0x6a8 /* deprecated */
+#define XK_Cyrillic_lje 0x6a9
+#define XK_Serbian_lje 0x6a9 /* deprecated */
+#define XK_Cyrillic_nje 0x6aa
+#define XK_Serbian_nje 0x6aa /* deprecated */
+#define XK_Serbian_tshe 0x6ab
+#define XK_Macedonia_kje 0x6ac
+#define XK_Byelorussian_shortu 0x6ae
+#define XK_Cyrillic_dzhe 0x6af
+#define XK_Serbian_dze 0x6af /* deprecated */
+#define XK_numerosign 0x6b0
+#define XK_Serbian_DJE 0x6b1
+#define XK_Macedonia_GJE 0x6b2
+#define XK_Cyrillic_IO 0x6b3
+#define XK_Ukrainian_IE 0x6b4
+#define XK_Ukranian_JE 0x6b4 /* deprecated */
+#define XK_Macedonia_DSE 0x6b5
+#define XK_Ukrainian_I 0x6b6
+#define XK_Ukranian_I 0x6b6 /* deprecated */
+#define XK_Ukrainian_YI 0x6b7
+#define XK_Ukranian_YI 0x6b7 /* deprecated */
+#define XK_Cyrillic_JE 0x6b8
+#define XK_Serbian_JE 0x6b8 /* deprecated */
+#define XK_Cyrillic_LJE 0x6b9
+#define XK_Serbian_LJE 0x6b9 /* deprecated */
+#define XK_Cyrillic_NJE 0x6ba
+#define XK_Serbian_NJE 0x6ba /* deprecated */
+#define XK_Serbian_TSHE 0x6bb
+#define XK_Macedonia_KJE 0x6bc
+#define XK_Byelorussian_SHORTU 0x6be
+#define XK_Cyrillic_DZHE 0x6bf
+#define XK_Serbian_DZE 0x6bf /* deprecated */
+#define XK_Cyrillic_yu 0x6c0
+#define XK_Cyrillic_a 0x6c1
+#define XK_Cyrillic_be 0x6c2
+#define XK_Cyrillic_tse 0x6c3
+#define XK_Cyrillic_de 0x6c4
+#define XK_Cyrillic_ie 0x6c5
+#define XK_Cyrillic_ef 0x6c6
+#define XK_Cyrillic_ghe 0x6c7
+#define XK_Cyrillic_ha 0x6c8
+#define XK_Cyrillic_i 0x6c9
+#define XK_Cyrillic_shorti 0x6ca
+#define XK_Cyrillic_ka 0x6cb
+#define XK_Cyrillic_el 0x6cc
+#define XK_Cyrillic_em 0x6cd
+#define XK_Cyrillic_en 0x6ce
+#define XK_Cyrillic_o 0x6cf
+#define XK_Cyrillic_pe 0x6d0
+#define XK_Cyrillic_ya 0x6d1
+#define XK_Cyrillic_er 0x6d2
+#define XK_Cyrillic_es 0x6d3
+#define XK_Cyrillic_te 0x6d4
+#define XK_Cyrillic_u 0x6d5
+#define XK_Cyrillic_zhe 0x6d6
+#define XK_Cyrillic_ve 0x6d7
+#define XK_Cyrillic_softsign 0x6d8
+#define XK_Cyrillic_yeru 0x6d9
+#define XK_Cyrillic_ze 0x6da
+#define XK_Cyrillic_sha 0x6db
+#define XK_Cyrillic_e 0x6dc
+#define XK_Cyrillic_shcha 0x6dd
+#define XK_Cyrillic_che 0x6de
+#define XK_Cyrillic_hardsign 0x6df
+#define XK_Cyrillic_YU 0x6e0
+#define XK_Cyrillic_A 0x6e1
+#define XK_Cyrillic_BE 0x6e2
+#define XK_Cyrillic_TSE 0x6e3
+#define XK_Cyrillic_DE 0x6e4
+#define XK_Cyrillic_IE 0x6e5
+#define XK_Cyrillic_EF 0x6e6
+#define XK_Cyrillic_GHE 0x6e7
+#define XK_Cyrillic_HA 0x6e8
+#define XK_Cyrillic_I 0x6e9
+#define XK_Cyrillic_SHORTI 0x6ea
+#define XK_Cyrillic_KA 0x6eb
+#define XK_Cyrillic_EL 0x6ec
+#define XK_Cyrillic_EM 0x6ed
+#define XK_Cyrillic_EN 0x6ee
+#define XK_Cyrillic_O 0x6ef
+#define XK_Cyrillic_PE 0x6f0
+#define XK_Cyrillic_YA 0x6f1
+#define XK_Cyrillic_ER 0x6f2
+#define XK_Cyrillic_ES 0x6f3
+#define XK_Cyrillic_TE 0x6f4
+#define XK_Cyrillic_U 0x6f5
+#define XK_Cyrillic_ZHE 0x6f6
+#define XK_Cyrillic_VE 0x6f7
+#define XK_Cyrillic_SOFTSIGN 0x6f8
+#define XK_Cyrillic_YERU 0x6f9
+#define XK_Cyrillic_ZE 0x6fa
+#define XK_Cyrillic_SHA 0x6fb
+#define XK_Cyrillic_E 0x6fc
+#define XK_Cyrillic_SHCHA 0x6fd
+#define XK_Cyrillic_CHE 0x6fe
+#define XK_Cyrillic_HARDSIGN 0x6ff
+#endif /* XK_CYRILLIC */
+
+/*
+ * Greek
+ * Byte 3 = 7
+ */
+
+#ifdef XK_GREEK
+#define XK_Greek_ALPHAaccent 0x7a1
+#define XK_Greek_EPSILONaccent 0x7a2
+#define XK_Greek_ETAaccent 0x7a3
+#define XK_Greek_IOTAaccent 0x7a4
+#define XK_Greek_IOTAdiaeresis 0x7a5
+#define XK_Greek_OMICRONaccent 0x7a7
+#define XK_Greek_UPSILONaccent 0x7a8
+#define XK_Greek_UPSILONdieresis 0x7a9
+#define XK_Greek_OMEGAaccent 0x7ab
+#define XK_Greek_accentdieresis 0x7ae
+#define XK_Greek_horizbar 0x7af
+#define XK_Greek_alphaaccent 0x7b1
+#define XK_Greek_epsilonaccent 0x7b2
+#define XK_Greek_etaaccent 0x7b3
+#define XK_Greek_iotaaccent 0x7b4
+#define XK_Greek_iotadieresis 0x7b5
+#define XK_Greek_iotaaccentdieresis 0x7b6
+#define XK_Greek_omicronaccent 0x7b7
+#define XK_Greek_upsilonaccent 0x7b8
+#define XK_Greek_upsilondieresis 0x7b9
+#define XK_Greek_upsilonaccentdieresis 0x7ba
+#define XK_Greek_omegaaccent 0x7bb
+#define XK_Greek_ALPHA 0x7c1
+#define XK_Greek_BETA 0x7c2
+#define XK_Greek_GAMMA 0x7c3
+#define XK_Greek_DELTA 0x7c4
+#define XK_Greek_EPSILON 0x7c5
+#define XK_Greek_ZETA 0x7c6
+#define XK_Greek_ETA 0x7c7
+#define XK_Greek_THETA 0x7c8
+#define XK_Greek_IOTA 0x7c9
+#define XK_Greek_KAPPA 0x7ca
+#define XK_Greek_LAMDA 0x7cb
+#define XK_Greek_LAMBDA 0x7cb
+#define XK_Greek_MU 0x7cc
+#define XK_Greek_NU 0x7cd
+#define XK_Greek_XI 0x7ce
+#define XK_Greek_OMICRON 0x7cf
+#define XK_Greek_PI 0x7d0
+#define XK_Greek_RHO 0x7d1
+#define XK_Greek_SIGMA 0x7d2
+#define XK_Greek_TAU 0x7d4
+#define XK_Greek_UPSILON 0x7d5
+#define XK_Greek_PHI 0x7d6
+#define XK_Greek_CHI 0x7d7
+#define XK_Greek_PSI 0x7d8
+#define XK_Greek_OMEGA 0x7d9
+#define XK_Greek_alpha 0x7e1
+#define XK_Greek_beta 0x7e2
+#define XK_Greek_gamma 0x7e3
+#define XK_Greek_delta 0x7e4
+#define XK_Greek_epsilon 0x7e5
+#define XK_Greek_zeta 0x7e6
+#define XK_Greek_eta 0x7e7
+#define XK_Greek_theta 0x7e8
+#define XK_Greek_iota 0x7e9
+#define XK_Greek_kappa 0x7ea
+#define XK_Greek_lamda 0x7eb
+#define XK_Greek_lambda 0x7eb
+#define XK_Greek_mu 0x7ec
+#define XK_Greek_nu 0x7ed
+#define XK_Greek_xi 0x7ee
+#define XK_Greek_omicron 0x7ef
+#define XK_Greek_pi 0x7f0
+#define XK_Greek_rho 0x7f1
+#define XK_Greek_sigma 0x7f2
+#define XK_Greek_finalsmallsigma 0x7f3
+#define XK_Greek_tau 0x7f4
+#define XK_Greek_upsilon 0x7f5
+#define XK_Greek_phi 0x7f6
+#define XK_Greek_chi 0x7f7
+#define XK_Greek_psi 0x7f8
+#define XK_Greek_omega 0x7f9
+#define XK_Greek_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_GREEK */
+
+/*
+ * Technical
+ * Byte 3 = 8
+ */
+
+#ifdef XK_TECHNICAL
+#define XK_leftradical 0x8a1
+#define XK_topleftradical 0x8a2
+#define XK_horizconnector 0x8a3
+#define XK_topintegral 0x8a4
+#define XK_botintegral 0x8a5
+#define XK_vertconnector 0x8a6
+#define XK_topleftsqbracket 0x8a7
+#define XK_botleftsqbracket 0x8a8
+#define XK_toprightsqbracket 0x8a9
+#define XK_botrightsqbracket 0x8aa
+#define XK_topleftparens 0x8ab
+#define XK_botleftparens 0x8ac
+#define XK_toprightparens 0x8ad
+#define XK_botrightparens 0x8ae
+#define XK_leftmiddlecurlybrace 0x8af
+#define XK_rightmiddlecurlybrace 0x8b0
+#define XK_topleftsummation 0x8b1
+#define XK_botleftsummation 0x8b2
+#define XK_topvertsummationconnector 0x8b3
+#define XK_botvertsummationconnector 0x8b4
+#define XK_toprightsummation 0x8b5
+#define XK_botrightsummation 0x8b6
+#define XK_rightmiddlesummation 0x8b7
+#define XK_lessthanequal 0x8bc
+#define XK_notequal 0x8bd
+#define XK_greaterthanequal 0x8be
+#define XK_integral 0x8bf
+#define XK_therefore 0x8c0
+#define XK_variation 0x8c1
+#define XK_infinity 0x8c2
+#define XK_nabla 0x8c5
+#define XK_approximate 0x8c8
+#define XK_similarequal 0x8c9
+#define XK_ifonlyif 0x8cd
+#define XK_implies 0x8ce
+#define XK_identical 0x8cf
+#define XK_radical 0x8d6
+#define XK_includedin 0x8da
+#define XK_includes 0x8db
+#define XK_intersection 0x8dc
+#define XK_union 0x8dd
+#define XK_logicaland 0x8de
+#define XK_logicalor 0x8df
+#define XK_partialderivative 0x8ef
+#define XK_function 0x8f6
+#define XK_leftarrow 0x8fb
+#define XK_uparrow 0x8fc
+#define XK_rightarrow 0x8fd
+#define XK_downarrow 0x8fe
+#endif /* XK_TECHNICAL */
+
+/*
+ * Special
+ * Byte 3 = 9
+ */
+
+#ifdef XK_SPECIAL
+#define XK_blank 0x9df
+#define XK_soliddiamond 0x9e0
+#define XK_checkerboard 0x9e1
+#define XK_ht 0x9e2
+#define XK_ff 0x9e3
+#define XK_cr 0x9e4
+#define XK_lf 0x9e5
+#define XK_nl 0x9e8
+#define XK_vt 0x9e9
+#define XK_lowrightcorner 0x9ea
+#define XK_uprightcorner 0x9eb
+#define XK_upleftcorner 0x9ec
+#define XK_lowleftcorner 0x9ed
+#define XK_crossinglines 0x9ee
+#define XK_horizlinescan1 0x9ef
+#define XK_horizlinescan3 0x9f0
+#define XK_horizlinescan5 0x9f1
+#define XK_horizlinescan7 0x9f2
+#define XK_horizlinescan9 0x9f3
+#define XK_leftt 0x9f4
+#define XK_rightt 0x9f5
+#define XK_bott 0x9f6
+#define XK_topt 0x9f7
+#define XK_vertbar 0x9f8
+#endif /* XK_SPECIAL */
+
+/*
+ * Publishing
+ * Byte 3 = a
+ */
+
+#ifdef XK_PUBLISHING
+#define XK_emspace 0xaa1
+#define XK_enspace 0xaa2
+#define XK_em3space 0xaa3
+#define XK_em4space 0xaa4
+#define XK_digitspace 0xaa5
+#define XK_punctspace 0xaa6
+#define XK_thinspace 0xaa7
+#define XK_hairspace 0xaa8
+#define XK_emdash 0xaa9
+#define XK_endash 0xaaa
+#define XK_signifblank 0xaac
+#define XK_ellipsis 0xaae
+#define XK_doubbaselinedot 0xaaf
+#define XK_onethird 0xab0
+#define XK_twothirds 0xab1
+#define XK_onefifth 0xab2
+#define XK_twofifths 0xab3
+#define XK_threefifths 0xab4
+#define XK_fourfifths 0xab5
+#define XK_onesixth 0xab6
+#define XK_fivesixths 0xab7
+#define XK_careof 0xab8
+#define XK_figdash 0xabb
+#define XK_leftanglebracket 0xabc
+#define XK_decimalpoint 0xabd
+#define XK_rightanglebracket 0xabe
+#define XK_marker 0xabf
+#define XK_oneeighth 0xac3
+#define XK_threeeighths 0xac4
+#define XK_fiveeighths 0xac5
+#define XK_seveneighths 0xac6
+#define XK_trademark 0xac9
+#define XK_signaturemark 0xaca
+#define XK_trademarkincircle 0xacb
+#define XK_leftopentriangle 0xacc
+#define XK_rightopentriangle 0xacd
+#define XK_emopencircle 0xace
+#define XK_emopenrectangle 0xacf
+#define XK_leftsinglequotemark 0xad0
+#define XK_rightsinglequotemark 0xad1
+#define XK_leftdoublequotemark 0xad2
+#define XK_rightdoublequotemark 0xad3
+#define XK_prescription 0xad4
+#define XK_minutes 0xad6
+#define XK_seconds 0xad7
+#define XK_latincross 0xad9
+#define XK_hexagram 0xada
+#define XK_filledrectbullet 0xadb
+#define XK_filledlefttribullet 0xadc
+#define XK_filledrighttribullet 0xadd
+#define XK_emfilledcircle 0xade
+#define XK_emfilledrect 0xadf
+#define XK_enopencircbullet 0xae0
+#define XK_enopensquarebullet 0xae1
+#define XK_openrectbullet 0xae2
+#define XK_opentribulletup 0xae3
+#define XK_opentribulletdown 0xae4
+#define XK_openstar 0xae5
+#define XK_enfilledcircbullet 0xae6
+#define XK_enfilledsqbullet 0xae7
+#define XK_filledtribulletup 0xae8
+#define XK_filledtribulletdown 0xae9
+#define XK_leftpointer 0xaea
+#define XK_rightpointer 0xaeb
+#define XK_club 0xaec
+#define XK_diamond 0xaed
+#define XK_heart 0xaee
+#define XK_maltesecross 0xaf0
+#define XK_dagger 0xaf1
+#define XK_doubledagger 0xaf2
+#define XK_checkmark 0xaf3
+#define XK_ballotcross 0xaf4
+#define XK_musicalsharp 0xaf5
+#define XK_musicalflat 0xaf6
+#define XK_malesymbol 0xaf7
+#define XK_femalesymbol 0xaf8
+#define XK_telephone 0xaf9
+#define XK_telephonerecorder 0xafa
+#define XK_phonographcopyright 0xafb
+#define XK_caret 0xafc
+#define XK_singlelowquotemark 0xafd
+#define XK_doublelowquotemark 0xafe
+#define XK_cursor 0xaff
+#endif /* XK_PUBLISHING */
+
+/*
+ * APL
+ * Byte 3 = b
+ */
+
+#ifdef XK_APL
+#define XK_leftcaret 0xba3
+#define XK_rightcaret 0xba6
+#define XK_downcaret 0xba8
+#define XK_upcaret 0xba9
+#define XK_overbar 0xbc0
+#define XK_downtack 0xbc2
+#define XK_upshoe 0xbc3
+#define XK_downstile 0xbc4
+#define XK_underbar 0xbc6
+#define XK_jot 0xbca
+#define XK_quad 0xbcc
+#define XK_uptack 0xbce
+#define XK_circle 0xbcf
+#define XK_upstile 0xbd3
+#define XK_downshoe 0xbd6
+#define XK_rightshoe 0xbd8
+#define XK_leftshoe 0xbda
+#define XK_lefttack 0xbdc
+#define XK_righttack 0xbfc
+#endif /* XK_APL */
+
+/*
+ * Hebrew
+ * Byte 3 = c
+ */
+
+#ifdef XK_HEBREW
+#define XK_hebrew_doublelowline 0xcdf
+#define XK_hebrew_aleph 0xce0
+#define XK_hebrew_bet 0xce1
+#define XK_hebrew_beth 0xce1 /* deprecated */
+#define XK_hebrew_gimel 0xce2
+#define XK_hebrew_gimmel 0xce2 /* deprecated */
+#define XK_hebrew_dalet 0xce3
+#define XK_hebrew_daleth 0xce3 /* deprecated */
+#define XK_hebrew_he 0xce4
+#define XK_hebrew_waw 0xce5
+#define XK_hebrew_zain 0xce6
+#define XK_hebrew_zayin 0xce6 /* deprecated */
+#define XK_hebrew_chet 0xce7
+#define XK_hebrew_het 0xce7 /* deprecated */
+#define XK_hebrew_tet 0xce8
+#define XK_hebrew_teth 0xce8 /* deprecated */
+#define XK_hebrew_yod 0xce9
+#define XK_hebrew_finalkaph 0xcea
+#define XK_hebrew_kaph 0xceb
+#define XK_hebrew_lamed 0xcec
+#define XK_hebrew_finalmem 0xced
+#define XK_hebrew_mem 0xcee
+#define XK_hebrew_finalnun 0xcef
+#define XK_hebrew_nun 0xcf0
+#define XK_hebrew_samech 0xcf1
+#define XK_hebrew_samekh 0xcf1 /* deprecated */
+#define XK_hebrew_ayin 0xcf2
+#define XK_hebrew_finalpe 0xcf3
+#define XK_hebrew_pe 0xcf4
+#define XK_hebrew_finalzade 0xcf5
+#define XK_hebrew_finalzadi 0xcf5 /* deprecated */
+#define XK_hebrew_zade 0xcf6
+#define XK_hebrew_zadi 0xcf6 /* deprecated */
+#define XK_hebrew_qoph 0xcf7
+#define XK_hebrew_kuf 0xcf7 /* deprecated */
+#define XK_hebrew_resh 0xcf8
+#define XK_hebrew_shin 0xcf9
+#define XK_hebrew_taw 0xcfa
+#define XK_hebrew_taf 0xcfa /* deprecated */
+#define XK_Hebrew_switch 0xFF7E /* Alias for mode_switch */
+#endif /* XK_HEBREW */
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11/license.terms b/Master/tlpkg/tlperl/lib/Tk/X11/license.terms
new file mode 100644
index 00000000000..03ca6fcb319
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11/license.terms
@@ -0,0 +1,39 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties. The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/Master/tlpkg/tlperl/lib/Tk/X11Font.pm b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm
new file mode 100644
index 00000000000..870dfd4b7dc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/X11Font.pm
@@ -0,0 +1,184 @@
+package Tk::X11Font;
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/X11Font.pm#7 $
+
+require Tk::Widget;
+require Tk::Xlib;
+use strict;
+
+Construct Tk::Widget 'X11Font';
+
+my @field = qw(foundry family weight slant swidth adstyle pixel
+ point xres yres space avgwidth registry encoding);
+
+map { eval "sub \u$_ { shift->elem('$_', \@_) }" } @field;
+
+use overload '""' => 'as_string';
+
+sub new
+{
+ my $pkg = shift;
+ my $w = shift;
+
+ my %me = ();
+ my $d = $w->Display;
+
+ local $_;
+
+ if(scalar(@_) == 1)
+ {
+ my $pattern = shift;
+
+ if($pattern =~ /\A(-[^-]*){14}\Z/)
+ {
+ @me{@field} = split(/-/, substr($pattern,1));
+ }
+ else
+ {
+ $me{Name} = $pattern;
+
+ if($pattern =~ /^[^-]?-([^-]*-){2,}/)
+ {
+ my $f = $d->XListFonts($pattern,1);
+
+ if($f && $f =~ /\A(-[^-]*){14}/)
+ {
+ my @f = split(/-/, substr($f,1));
+ my @n = split(/-/, $pattern);
+ my %f = ();
+ my $i = 0;
+
+ shift @n if($pattern =~ /\A-/);
+
+ while(@n && @f)
+ {
+ if($n[0] eq '*')
+ {
+ shift @n;
+ }
+ elsif($n[0] eq $f[0])
+ {
+ $f{$field[$i]} = shift @n;
+ }
+ $i++;
+ shift @f;
+ }
+
+ %me = %f
+ unless(@n);
+ }
+ }
+ }
+ }
+ else
+ {
+ %me = @_;
+ }
+
+ map { $me{$_} ||= '*' } @field;
+
+ $me{Display} = $d;
+ $me{MainWin} = $w->MainWindow;
+
+ bless \%me, $pkg;
+}
+
+sub Pattern
+{
+ my $me = shift;
+ return join('-', '',@{$me}{@field});
+}
+
+sub Name
+{
+ my $me = shift;
+ my $max = wantarray ? shift || 128 : 1;
+
+ if ($^O eq 'MSWin32' or ($^O eq 'cygwin' and $Tk::platform eq 'MSWin32'))
+ {
+ my $name = $me->{Name};
+ if (!defined $name)
+ {
+ my $fm = $me->{'family'} || 'system';
+ my $sz = -int($me->{'point'}/10) || -($me->{'pixel'}) || 12;
+ my @opt = (-family => $fm, -size => $sz );
+ my $wt = $me->{'weight'};
+ if (defined $wt)
+ {
+ $wt = 'normal' unless $wt =~ /bold/i;
+ push(@opt,-weight => lc($wt));
+ }
+ my $sl = $me->{'slant'};
+ if (defined $sl)
+ {
+ $sl = ($sl =~ /^[io]/) ? 'italic' : 'roman';
+ push(@opt,-slant => $sl);
+ }
+ $name = join(' ',@opt);
+ }
+ return $name;
+ }
+ else
+ {
+ my $name = $me->{Name} ||
+ join('-', '',@{$me}{@field});
+ return $me->{Display}->XListFonts($name,$max);
+ }
+}
+
+sub as_string
+{
+ return shift->Name;
+}
+
+sub elem
+{
+ my $me = shift;
+ my $elem = shift;
+
+ return undef
+ if(exists $me->{'Name'});
+
+ my $old = $me->{$elem};
+
+ $me->{$elem} = shift
+ if(@_);
+
+ $old;
+}
+
+sub Clone
+{
+ my $me = shift;
+
+ $me = bless { %$me }, ref($me);
+
+ unless(exists $me->{'Name'})
+ {
+ while(@_)
+ {
+ my $k = shift;
+ my $v = shift || $me->{MainWin}->BackTrace('Tk::Font->Clone( key => value, ... )');
+ $me->{$k} = $v;
+ }
+ }
+
+ $me;
+}
+
+sub ascent
+{
+ my $me = shift;
+ my $name = $me->Name;
+ $me->{MainWin}->fontMetrics($name, '-ascent');
+}
+
+sub descent
+{
+ my $me = shift;
+ my $name = $me->Name;
+ $me->{MainWin}->fontMetrics($name, '-descent');
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif b/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif
new file mode 100644
index 00000000000..cb88bc0afd8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Xcamel.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl/lib/Tk/Xlib.pm b/Master/tlpkg/tlperl/lib/Tk/Xlib.pm
new file mode 100644
index 00000000000..1432361dc18
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Xlib.pm
@@ -0,0 +1,15 @@
+package Tk::Xlib;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Xlib/Xlib.pm#4 $
+
+use Tk qw($XS_VERSION);
+use Exporter;
+
+use base qw(DynaLoader Exporter);
+@EXPORT_OK = qw(XDrawString XLoadFont XDrawRectangle);
+
+bootstrap Tk::Xlib;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/Xrm.pm b/Master/tlpkg/tlperl/lib/Tk/Xrm.pm
new file mode 100644
index 00000000000..271ad59a237
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Xrm.pm
@@ -0,0 +1,11 @@
+package Tk::Xrm;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Xrm.pm#4 $
+
+use Tk ();
+1;
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm b/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm
new file mode 100644
index 00000000000..fc82949945b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/act_folder.xbm
@@ -0,0 +1,5 @@
+#define act_folder_width 16
+#define act_folder_height 10
+static unsigned char act_folder_bits[] = {
+ 0xfc, 0x00, 0xaa, 0x0f, 0x55, 0x15, 0xeb, 0xff, 0x15, 0x80, 0x0b, 0x40,
+ 0x05, 0x20, 0x03, 0x10, 0x01, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm b/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm
new file mode 100644
index 00000000000..0e7d682713a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/act_folder.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * act_folder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 4 1",
+/* colors */
+" s None c None",
+". c black",
+"X c yellow",
+"o c #5B5B57574646",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".oXoXoXoXoXo. ",
+".XoX............",
+".oX.XXXXXXXXXXX.",
+".Xo.XXXXXXXXXX. ",
+".o.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/anim.gif b/Master/tlpkg/tlperl/lib/Tk/anim.gif
new file mode 100644
index 00000000000..96a50b701be
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/anim.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm b/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm
new file mode 100644
index 00000000000..ea43fc75e7a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/arrowdownwin.xbm
@@ -0,0 +1,5 @@
+#define arrowdownwin2_width 9
+#define arrowdownwin2_height 13
+static char arrowdownwin2_bits[] = {
+ 0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x7c,0xfe,0x38,0xfe,0x10,
+ 0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe,0x00,0xfe};
diff --git a/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm b/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm
new file mode 100644
index 00000000000..ee0664a4727
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/balArrow.xbm
@@ -0,0 +1,4 @@
+#define balArrow_width 6
+#define balArrow_height 6
+static char balArrow_bits[] = {
+ 0x1f, 0x07, 0x07, 0x09, 0x11, 0x20};
diff --git a/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm b/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm
new file mode 100644
index 00000000000..ae4054488b9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/cbxarrow.xbm
@@ -0,0 +1,6 @@
+#define cbxarrow_width 11
+#define cbxarrow_height 14
+static char cbxarrow_bits[] = {
+ 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00,
+ 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00,
+ 0xfe, 0x03, 0xfe, 0x03};
diff --git a/Master/tlpkg/tlperl/lib/Tk/file.xbm b/Master/tlpkg/tlperl/lib/Tk/file.xbm
new file mode 100644
index 00000000000..7bf12bb4c9f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/file.xbm
@@ -0,0 +1,5 @@
+#define file_width 12
+#define file_height 12
+static unsigned char file_bits[] = {
+ 0xfe, 0x00, 0x02, 0x03, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,
+ 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0xfe, 0x03};
diff --git a/Master/tlpkg/tlperl/lib/Tk/file.xpm b/Master/tlpkg/tlperl/lib/Tk/file.xpm
new file mode 100644
index 00000000000..10cc24f9a1e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/file.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * file_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c white",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/folder.xbm b/Master/tlpkg/tlperl/lib/Tk/folder.xbm
new file mode 100644
index 00000000000..0398f0de777
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/folder.xbm
@@ -0,0 +1,5 @@
+#define folder_width 16
+#define folder_height 10
+static unsigned char folder_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0x01, 0x08,
+ 0x01, 0x08, 0x01, 0x08, 0x01, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl/lib/Tk/folder.xpm b/Master/tlpkg/tlperl/lib/Tk/folder.xpm
new file mode 100644
index 00000000000..fda7c15a549
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/folder.xpm
@@ -0,0 +1,21 @@
+/* XPM */
+static char * folder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+".XXXXXXXXXXX. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/icon.gif b/Master/tlpkg/tlperl/lib/Tk/icon.gif
new file mode 100644
index 00000000000..dfe6b6621f2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/icon.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl/lib/Tk/install.pm b/Master/tlpkg/tlperl/lib/Tk/install.pm
new file mode 100644
index 00000000000..2392dc84fca
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/install.pm
@@ -0,0 +1,37 @@
+package Tk::install;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/install.pm#4 $
+
+use base qw(Exporter);
+@EXPORT = qw(installbin);
+
+use Config;
+
+sub installbin
+{
+ my $prog = shift(@ARGV);
+ my $start = $Config{'startperl'};
+ my $perl = $Config{'perl'} || 'perl';
+ $start =~ s/$perl$/$prog/;
+ while (($src,$dst) = splice(@ARGV,0,2))
+ {
+ open(SRC,"<$src") || die "Cannot open $src:$!";
+ my $line = <SRC>;
+ $line =~ s/^#!\s*\S+/$start/;
+ warn $line;
+ chmod(0755,$dst) if (-f $dst);
+ open(DST,">$dst") || die "Cannot open $dst:$!";
+ print "installbin $src => $dst\n";
+ do
+ {
+ print DST $line;
+ } while (defined($line = <SRC>));
+ close(SRC);
+ close(DST);
+ chmod(0555,$dst);
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/license.terms b/Master/tlpkg/tlperl/lib/Tk/license.terms
new file mode 100644
index 00000000000..6a5d3728366
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/license.terms
@@ -0,0 +1,35 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties. The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+RESTRICTED RIGHTS: Use, duplication or disclosure by the government
+is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
+of the Rights in Technical Data and Computer Software Clause as DFARS
+252.227-7013 and FAR 52.227-19.
+0 in license.terms
+0 in license.terms
+0 in license.terms
diff --git a/Master/tlpkg/tlperl/lib/Tk/openfile.xbm b/Master/tlpkg/tlperl/lib/Tk/openfile.xbm
new file mode 100644
index 00000000000..859e2e57608
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/openfile.xbm
@@ -0,0 +1,5 @@
+#define openfile_width 16
+#define openfile_height 12
+static unsigned char openfile_bits[] = {
+ 0x00, 0x00, 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0xa1, 0xaa,
+ 0x51, 0x55, 0xa9, 0x2a, 0x55, 0x15, 0xab, 0x0a, 0xff, 0x07, 0x00, 0x00};
diff --git a/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm b/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm
new file mode 100644
index 00000000000..59ee624efd0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/openfolder.xbm
@@ -0,0 +1,5 @@
+#define openfolder_width 16
+#define openfolder_height 10
+static unsigned char openfolder_bits[] = {
+ 0xfc, 0x00, 0x02, 0x07, 0x01, 0x08, 0xc1, 0xff, 0x21, 0x80, 0x11, 0x40,
+ 0x09, 0x20, 0x05, 0x10, 0x03, 0x08, 0xff, 0x07};
diff --git a/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm b/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm
new file mode 100644
index 00000000000..191fe1e72bc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/openfolder.xpm
@@ -0,0 +1,21 @@
+/* XPM */
+static char * openfolder_xpm[] = {
+/* width height num_colors chars_per_pixel */
+"16 12 3 1",
+/* colors */
+" s None c None",
+". c black",
+"X c #f0ff80",
+/* pixels */
+" .... ",
+" .XXXX. ",
+" .XXXXXX. ",
+"............. ",
+".XXXXXXXXXXX. ",
+".XXX............",
+".XX.XXXXXXXXXXX.",
+".XX.XXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+".X.XXXXXXXXXXX. ",
+"..XXXXXXXXXX.. ",
+"............. "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/prolog.ps b/Master/tlpkg/tlperl/lib/Tk/prolog.ps
new file mode 100644
index 00000000000..409e06a65a0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/prolog.ps
@@ -0,0 +1,284 @@
+%%BeginProlog
+50 dict begin
+
+% This is a standard prolog for Postscript generated by Tk's canvas
+% widget.
+% SCCS: @(#) prolog.ps 1.5 96/02/17 17:45:11
+
+% The definitions below just define all of the variables used in
+% any of the procedures here. This is needed for obscure reasons
+% explained on p. 716 of the Postscript manual (Section H.2.7,
+% "Initializing Variables," in the section on Encapsulated Postscript).
+
+/baseline 0 def
+/stipimage 0 def
+/height 0 def
+/justify 0 def
+/lineLength 0 def
+/spacing 0 def
+/stipple 0 def
+/strings 0 def
+/xoffset 0 def
+/yoffset 0 def
+/tmpstip null def
+
+% Define the array ISOLatin1Encoding (which specifies how characters are
+% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript
+% level 2 is supposed to define it, but level 1 doesn't).
+
+systemdict /ISOLatin1Encoding known not {
+ /ISOLatin1Encoding [
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /space /exclam /quotedbl /numbersign /dollar /percent /ampersand
+ /quoteright
+ /parenleft /parenright /asterisk /plus /comma /minus /period /slash
+ /zero /one /two /three /four /five /six /seven
+ /eight /nine /colon /semicolon /less /equal /greater /question
+ /at /A /B /C /D /E /F /G
+ /H /I /J /K /L /M /N /O
+ /P /Q /R /S /T /U /V /W
+ /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
+ /quoteleft /a /b /c /d /e /f /g
+ /h /i /j /k /l /m /n /o
+ /p /q /r /s /t /u /v /w
+ /x /y /z /braceleft /bar /braceright /asciitilde /space
+ /space /space /space /space /space /space /space /space
+ /space /space /space /space /space /space /space /space
+ /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
+ /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron
+ /space /exclamdown /cent /sterling /currency /yen /brokenbar /section
+ /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen
+ /registered /macron
+ /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
+ /periodcentered
+ /cedillar /onesuperior /ordmasculine /guillemotright /onequarter
+ /onehalf /threequarters /questiondown
+ /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
+ /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex
+ /Idieresis
+ /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
+ /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
+ /germandbls
+ /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla
+ /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex
+ /idieresis
+ /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide
+ /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn
+ /ydieresis
+ ] def
+} if
+
+% font ISOEncode font
+% This procedure changes the encoding of a font from the default
+% Postscript encoding to ISOLatin1. It's typically invoked just
+% before invoking "setfont". The body of this procedure comes from
+% Section 5.6.1 of the Postscript book.
+
+/ISOEncode {
+ dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding ISOLatin1Encoding def
+ currentdict
+ end
+
+ % I'm not sure why it's necessary to use "definefont" on this new
+ % font, but it seems to be important; just use the name "Temporary"
+ % for the font.
+
+ /Temporary exch definefont
+} bind def
+
+% StrokeClip
+%
+% This procedure converts the current path into a clip area under
+% the assumption of stroking. It's a bit tricky because some Postscript
+% interpreters get errors during strokepath for dashed lines. If
+% this happens then turn off dashes and try again.
+
+/StrokeClip {
+ {strokepath} stopped {
+ (This Postscript printer gets limitcheck overflows when) =
+ (stippling dashed lines; lines will be printed solid instead.) =
+ [] 0 setdash strokepath} if
+ clip
+} bind def
+
+% desiredSize EvenPixels closestSize
+%
+% The procedure below is used for stippling. Given the optimal size
+% of a dot in a stipple pattern in the current user coordinate system,
+% compute the closest size that is an exact multiple of the device's
+% pixel size. This allows stipple patterns to be displayed without
+% aliasing effects.
+
+/EvenPixels {
+ % Compute exact number of device pixels per stipple dot.
+ dup 0 matrix currentmatrix dtransform
+ dup mul exch dup mul add sqrt
+
+ % Round to an integer, make sure the number is at least 1, and compute
+ % user coord distance corresponding to this.
+ dup round dup 1 lt {pop 1} if
+ exch div mul
+} bind def
+
+% width height string StippleFill --
+%
+% Given a path already set up and a clipping region generated from
+% it, this procedure will fill the clipping region with a stipple
+% pattern. "String" contains a proper image description of the
+% stipple pattern and "width" and "height" give its dimensions. Each
+% stipple dot is assumed to be about one unit across in the current
+% user coordinate system. This procedure trashes the graphics state.
+
+/StippleFill {
+ % The following code is needed to work around a NeWSprint bug.
+
+ /tmpstip 1 index def
+
+ % Change the scaling so that one user unit in user coordinates
+ % corresponds to the size of one stipple dot.
+ 1 EvenPixels dup scale
+
+ % Compute the bounding box occupied by the path (which is now
+ % the clipping region), and round the lower coordinates down
+ % to the nearest starting point for the stipple pattern. Be
+ % careful about negative numbers, since the rounding works
+ % differently on them.
+
+ pathbbox
+ 4 2 roll
+ 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
+ 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
+
+ % Stack now: width height string y1 y2 x1 x2
+ % Below is a doubly-nested for loop to iterate across this area
+ % in units of the stipple pattern size, going up columns then
+ % across rows, blasting out a stipple-pattern-sized rectangle at
+ % each position
+
+ 6 index exch {
+ 2 index 5 index 3 index {
+ % Stack now: width height string y1 y2 x y
+
+ gsave
+ 1 index exch translate
+ 5 index 5 index true matrix tmpstip imagemask
+ grestore
+ } for
+ pop
+ } for
+ pop pop pop pop pop
+} bind def
+
+% -- AdjustColor --
+% Given a color value already set for output by the caller, adjusts
+% that value to a grayscale or mono value if requested by the CL
+% variable.
+
+/AdjustColor {
+ CL 2 lt {
+ currentgray
+ CL 0 eq {
+ .5 lt {0} {1} ifelse
+ } if
+ setgray
+ } if
+} bind def
+
+% x y strings spacing xoffset yoffset justify stipple DrawText --
+% This procedure does all of the real work of drawing text. The
+% color and font must already have been set by the caller, and the
+% following arguments must be on the stack:
+%
+% x, y - Coordinates at which to draw text.
+% strings - An array of strings, one for each line of the text item,
+% in order from top to bottom.
+% spacing - Spacing between lines.
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.
+% stipple - Boolean value indicating whether or not text is to be
+% drawn in stippled fashion. If text is stippled,
+% procedure StippleText must have been defined to call
+% StippleFill in the right way.
+%
+% Also, when this procedure is invoked, the color and font must already
+% have been set for the text.
+
+/DrawText {
+ /stipple exch def
+ /justify exch def
+ /yoffset exch def
+ /xoffset exch def
+ /spacing exch def
+ /strings exch def
+
+ % First scan through all of the text to find the widest line.
+
+ /lineLength 0 def
+ strings {
+ stringwidth pop
+ dup lineLength gt {/lineLength exch def} {pop} ifelse
+ newpath
+ } forall
+
+ % Compute the baseline offset and the actual font height.
+
+ 0 0 moveto (TXygqPZ) false charpath
+ pathbbox dup /baseline exch def
+ exch pop exch sub /height exch def pop
+ newpath
+
+ % Translate coordinates first so that the origin is at the upper-left
+ % corner of the text's bounding box. Remember that x and y for
+ % positioning are still on the stack.
+
+ translate
+ lineLength xoffset mul
+ strings length 1 sub spacing mul height add yoffset mul translate
+
+ % Now use the baseline and justification information to translate so
+ % that the origin is at the baseline and positioning point for the
+ % first line of text.
+
+ justify lineLength mul baseline neg translate
+
+ % Iterate over each of the lines to output it. For each line,
+ % compute its width again so it can be properly justified, then
+ % display it.
+
+ strings {
+ dup stringwidth pop
+ justify neg mul 0 moveto
+ stipple {
+
+ % The text is stippled, so turn it into a path and print
+ % by calling StippledText, which in turn calls StippleFill.
+ % Unfortunately, many Postscript interpreters will get
+ % overflow errors if we try to do the whole string at
+ % once, so do it a character at a time.
+
+ gsave
+ /char (X) def
+ {
+ char 0 3 -1 roll put
+ currentpoint
+ gsave
+ char true charpath clip StippleText
+ grestore
+ char stringwidth translate
+ moveto
+ } forall
+ grestore
+ } {show} ifelse
+ 0 spacing neg translate
+ } forall
+} bind def
+
+%%EndProlog
diff --git a/Master/tlpkg/tlperl/lib/Tk/reindex.pl b/Master/tlpkg/tlperl/lib/Tk/reindex.pl
new file mode 100644
index 00000000000..7af5cc1d13f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/reindex.pl
@@ -0,0 +1,33 @@
+#!/bin/perl
+
+use lib qw(/home1/gbartels/textlist);
+use Tk;
+
+use Tk::TextReindex qw(Tk::ROText ROTextReindex);
+
+$mw=new MainWindow;
+
+my $idx;
+
+$w=$mw->ROTextReindex()->pack(-side => "top");
+$t=$mw->Label(-textvariable => \$idx)->pack(-side => "bottom");
+
+$w->bind('<Key>',sub{$idx=$w->index("insert")});
+
+$w->insert('end',"abcd\n");
+$w->insert('end',"efgh\n");
+$w->insert('end',"mnop\n");
+$w->insert('end',"qrst\n");
+$w->insert('end',"uvwx\n");
+
+$w->insert('2.0',"ijkl\n");
+
+my $string = $w->get('4.0');
+
+
+my $result = "reading index 4.0 : expect string to equal >q<, actual value is $string \n";
+$w->insert('end',$result);
+
+print $result;
+
+MainLoop;
diff --git a/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm b/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm
new file mode 100644
index 00000000000..06a40a96c84
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/srcfile.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * srcfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c gray91",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XXXXXXXX. ",
+" .XX...XXX. ",
+" .X.XXX.XX. ",
+" .X.XXXXXX. ",
+" .X.XXXXXX. ",
+" .XX....XX. ",
+" .XXXXXXXX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/textfile.xpm b/Master/tlpkg/tlperl/lib/Tk/textfile.xpm
new file mode 100644
index 00000000000..8fa8d2f9032
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/textfile.xpm
@@ -0,0 +1,18 @@
+/* XPM */
+static char * textfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c #000000000000",
+"X c #E0E0FFFFE0E0",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .X....XXX. ",
+" .XXXXXXXX. ",
+" .X...XXXX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .X.....XX. ",
+" .XXXXXXXX. ",
+" .......... "};
diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.def b/Master/tlpkg/tlperl/lib/Tk/tkGlue.def
new file mode 100644
index 00000000000..2f1662c71c2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.def
@@ -0,0 +1,130 @@
+#ifdef CAN_PROTOTYPE
+#define XSdec(x) XS(x)
+#else
+#define XSdec(x) void x()
+#endif
+
+#define TKXSRETURN(off) \
+ STMT_START { \
+ IV ptkAdj = (off); \
+ XSRETURN(ptkAdj); \
+ } STMT_END
+
+#ifndef PATCHLEVEL
+#include <patchlevel.h>
+#endif
+
+#if defined(PATCHLEVEL) && (PATCHLEVEL < 5)
+#define PL_sv_undef sv_undef
+#define PL_tainting tainting
+#define PL_tainted tainted
+#define PL_stack_base stack_base
+#define PL_stack_sp stack_sp
+#define PL_curcop curcop
+#endif
+
+#ifndef CopSTASH
+#define CopSTASH(c) c->cop_stash
+#define CopSTASH_set(c,h) (CopSTASH(c) = h)
+#endif
+
+#ifndef dTHX
+#define dTHR int maybeTHR
+#endif
+
+#ifndef dTHXs
+#ifdef PERL_IMPLICIT_SYS
+#define dTHXs dTHX
+#else
+#define dTHR int maybeTHR
+#endif
+#endif
+
+#ifndef ERRSV
+#define ERRSV GvSV(errgv)
+#endif
+
+#ifndef aTHX_
+#define aTHX_
+#endif
+
+#ifndef pTHX_
+#define pTHX_
+#endif
+
+#ifdef dirty
+#undef dirty
+#endif
+#ifdef bufptr
+#undef bufptr
+#endif
+#ifdef colors
+#undef colors
+#endif
+#ifdef JOIN
+#undef JOIN
+#endif
+
+#ifdef na
+#if PATCHLEVEL >= 5
+#undef na
+#endif
+#endif
+
+
+#define Tcl_Interp HV
+#define LangCallback SV
+#define Var SV *
+#define LangResultSave AV
+struct Lang_CmdInfo;
+#define Tcl_Command struct Lang_CmdInfo *
+struct WrappedRegExp;
+#define Tcl_RegExp struct WrappedRegExp *
+#define Tcl_Obj SV
+#define Tcl_DString SV *
+
+#ifndef PerlIO
+#define PerlIO FILE
+#define PerlIO_stderr() stderr
+#define PerlIO_printf fprintf
+#define PerlIO_flush(f) Fflush(f)
+#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
+#define PerlIO_putc(f,c) fputc(c,f)
+#define PerlIO_fileno(f) fileno(f)
+
+/* Now our interface to Configure's FILE_xxx macros */
+
+#ifdef USE_STDIO_PTR
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) FILE_ptr(f)
+#define PerlIO_get_cnt(f) FILE_cnt(f)
+
+#ifdef FILE_CNT_LVALUE
+#define PerlIO_canset_cnt(f) 1
+#ifdef FILE_PTR_LVALUE
+#define PerlIO_fast_gets(f) 1
+#endif
+#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c))
+#else
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_set_cnt(f,c) abort()
+#endif
+
+#ifdef FILE_PTR_LVALUE
+#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c))
+#else
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+#endif
+
+#else /* USE_STDIO_PTR */
+
+#define PerlIO_has_cntptr(f) 0
+#define PerlIO_get_cnt(f) (abort(),0)
+#define PerlIO_get_ptr(f) (abort(),0)
+#define PerlIO_set_cnt(f,c) abort()
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+
+#endif /* USE_STDIO_PTR */
+
+#endif
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.h b/Master/tlpkg/tlperl/lib/Tk/tkGlue.h
new file mode 100644
index 00000000000..31a7f861700
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.h
@@ -0,0 +1,79 @@
+#ifndef _TKGLUE
+#define _TKGLUE
+
+#ifndef BASEEXT
+#define BASEEXT "Tk"
+#endif
+
+#ifndef _TKOPTION
+#include "pTk/tkOption.h"
+#include "pTk/tkOption_f.h"
+#endif
+
+typedef struct EventAndKeySym
+ {XEvent event;
+ KeySym keySym;
+ Tcl_Interp *interp;
+ Tk_Window tkwin;
+ SV *window;
+ } EventAndKeySym;
+
+typedef struct Lang_CmdInfo
+ {Tcl_CmdInfo Tk;
+ Tcl_Interp *interp;
+ Tk_Window tkwin;
+ SV *image;
+ Tk_Font tkfont;
+ } Lang_CmdInfo;
+
+#include "vtab.def"
+
+
+#define VTABLE_INIT() IMPORT_VTABLES
+
+extern Lang_CmdInfo *WindowCommand _ANSI_ARGS_((SV *win,HV **hptr, int moan));
+extern Tk_Window SVtoWindow _ANSI_ARGS_((SV *win));
+extern Tk_Font SVtoFont _ANSI_ARGS_((SV *win));
+extern int Call_Tk _ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args));
+extern HV *InterpHv _ANSI_ARGS_((Tcl_Interp *interp,int fatal));
+extern SV *WidgetRef _ANSI_ARGS_((Tcl_Interp *interp, char *path));
+extern SV *ObjectRef _ANSI_ARGS_((Tcl_Interp *interp, char *path));
+extern SV *TkToWidget _ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp));
+extern SV *FindTkVarName _ANSI_ARGS_((CONST char *varName,int flags));
+extern void EnterWidgetMethods _ANSI_ARGS_((char *package, ...));
+extern SV *MakeReference _ANSI_ARGS_((SV * sv));
+extern Tk_Window TkToMainWindow _ANSI_ARGS_((Tk_Window tkwin));
+extern void Lang_TkSubCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc));
+extern void Lang_TkCommand _ANSI_ARGS_ ((char *name, Tcl_ObjCmdProc *proc));
+extern SV *XEvent_Info _((EventAndKeySym *obj,char *s));
+extern EventAndKeySym *SVtoEventAndKeySym _((SV *arg));
+extern int XSTkCommand _ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args));
+
+extern XS(XStoWidget);
+
+EXTERN void ClearErrorInfo _ANSI_ARGS_((SV *interp));
+EXTERN Tk_Window mainWindow;
+EXTERN void DumpStack _ANSI_ARGS_((CONST char *who));
+EXTERN void Boot_Glue (pTHX);
+EXTERN void Boot_Tix (pTHX);
+EXTERN void install_vtab _ANSI_ARGS_((char *name, void *table, size_t size));
+extern SV *TagIt _((SV *sv, char *type));
+extern void Font_DESTROY _((SV *sv));
+struct pTkCheckChain;
+extern void Tk_CheckHash _((SV *sv,struct pTkCheckChain *chain));
+
+extern int has_highbit(CONST char *s,int l);
+extern SV * sv_maybe_utf8(SV *sv);
+extern SV * Lang_SystemEncoding(void);
+
+#ifndef WIN32
+#define HWND void *
+#endif
+EXTERN HWND SVtoHWND _ANSI_ARGS_((SV *win));
+
+#ifdef WIN32
+#include "pTk/tkWinInt.h"
+#endif
+
+#endif
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.m b/Master/tlpkg/tlperl/lib/Tk/tkGlue.m
new file mode 100644
index 00000000000..922d1426a55
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.m
@@ -0,0 +1,74 @@
+#ifndef _TKGLUE_VM
+#define _TKGLUE_VM
+#include "tkGlue_f.h"
+#ifndef NO_VTABLES
+#ifndef Call_Tk
+# define Call_Tk (*TkglueVptr->V_Call_Tk)
+#endif
+
+#ifndef EnterWidgetMethods
+# define EnterWidgetMethods (*TkglueVptr->V_EnterWidgetMethods)
+#endif
+
+#ifndef FindTkVarName
+# define FindTkVarName (*TkglueVptr->V_FindTkVarName)
+#endif
+
+#ifndef InterpHv
+# define InterpHv (*TkglueVptr->V_InterpHv)
+#endif
+
+#ifndef Lang_TkCommand
+# define Lang_TkCommand (*TkglueVptr->V_Lang_TkCommand)
+#endif
+
+#ifndef Lang_TkSubCommand
+# define Lang_TkSubCommand (*TkglueVptr->V_Lang_TkSubCommand)
+#endif
+
+#ifndef MakeReference
+# define MakeReference (*TkglueVptr->V_MakeReference)
+#endif
+
+#ifndef ObjectRef
+# define ObjectRef (*TkglueVptr->V_ObjectRef)
+#endif
+
+#ifndef SVtoFont
+# define SVtoFont (*TkglueVptr->V_SVtoFont)
+#endif
+
+#ifndef SVtoHWND
+# define SVtoHWND (*TkglueVptr->V_SVtoHWND)
+#endif
+
+#ifndef SVtoWindow
+# define SVtoWindow (*TkglueVptr->V_SVtoWindow)
+#endif
+
+#ifndef TkToMainWindow
+# define TkToMainWindow (*TkglueVptr->V_TkToMainWindow)
+#endif
+
+#ifndef TkToWidget
+# define TkToWidget (*TkglueVptr->V_TkToWidget)
+#endif
+
+#ifndef WidgetRef
+# define WidgetRef (*TkglueVptr->V_WidgetRef)
+#endif
+
+#ifndef WindowCommand
+# define WindowCommand (*TkglueVptr->V_WindowCommand)
+#endif
+
+#ifndef XSTkCommand
+# define XSTkCommand (*TkglueVptr->V_XSTkCommand)
+#endif
+
+#ifndef install_vtab
+# define install_vtab (*TkglueVptr->V_install_vtab)
+#endif
+
+#endif /* NO_VTABLES */
+#endif /* _TKGLUE_VM */
diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue.t b/Master/tlpkg/tlperl/lib/Tk/tkGlue.t
new file mode 100644
index 00000000000..ff689ff5539
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue.t
@@ -0,0 +1,70 @@
+#ifdef _TKGLUE
+#ifndef Call_Tk
+VFUNC(int,Call_Tk,V_Call_Tk,_ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args)))
+#endif /* #ifndef Call_Tk */
+
+#ifndef EnterWidgetMethods
+VFUNC(void,EnterWidgetMethods,V_EnterWidgetMethods,_ANSI_ARGS_((char *package, ...)))
+#endif /* #ifndef EnterWidgetMethods */
+
+#ifndef FindTkVarName
+VFUNC(SV *,FindTkVarName,V_FindTkVarName,_ANSI_ARGS_((CONST char *varName,int flags)))
+#endif /* #ifndef FindTkVarName */
+
+#ifndef InterpHv
+VFUNC(HV *,InterpHv,V_InterpHv,_ANSI_ARGS_((Tcl_Interp *interp,int fatal)))
+#endif /* #ifndef InterpHv */
+
+#ifndef Lang_TkCommand
+VFUNC(void,Lang_TkCommand,V_Lang_TkCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc)))
+#endif /* #ifndef Lang_TkCommand */
+
+#ifndef Lang_TkSubCommand
+VFUNC(void,Lang_TkSubCommand,V_Lang_TkSubCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc)))
+#endif /* #ifndef Lang_TkSubCommand */
+
+#ifndef MakeReference
+VFUNC(SV *,MakeReference,V_MakeReference,_ANSI_ARGS_((SV * sv)))
+#endif /* #ifndef MakeReference */
+
+#ifndef ObjectRef
+VFUNC(SV *,ObjectRef,V_ObjectRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path)))
+#endif /* #ifndef ObjectRef */
+
+#ifndef SVtoFont
+VFUNC(Tk_Font,SVtoFont,V_SVtoFont,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoFont */
+
+#ifndef SVtoHWND
+VFUNC(HWND,SVtoHWND,V_SVtoHWND,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoHWND */
+
+#ifndef SVtoWindow
+VFUNC(Tk_Window,SVtoWindow,V_SVtoWindow,_ANSI_ARGS_((SV *win)))
+#endif /* #ifndef SVtoWindow */
+
+#ifndef TkToMainWindow
+VFUNC(Tk_Window,TkToMainWindow,V_TkToMainWindow,_ANSI_ARGS_((Tk_Window tkwin)))
+#endif /* #ifndef TkToMainWindow */
+
+#ifndef TkToWidget
+VFUNC(SV *,TkToWidget,V_TkToWidget,_ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp)))
+#endif /* #ifndef TkToWidget */
+
+#ifndef WidgetRef
+VFUNC(SV *,WidgetRef,V_WidgetRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path)))
+#endif /* #ifndef WidgetRef */
+
+#ifndef WindowCommand
+VFUNC(Lang_CmdInfo *,WindowCommand,V_WindowCommand,_ANSI_ARGS_((SV *win,HV **hptr, int moan)))
+#endif /* #ifndef WindowCommand */
+
+#ifndef XSTkCommand
+VFUNC(int,XSTkCommand,V_XSTkCommand,_ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args)))
+#endif /* #ifndef XSTkCommand */
+
+#ifndef install_vtab
+VFUNC(void,install_vtab,V_install_vtab,_ANSI_ARGS_((char *name, void *table, size_t size)))
+#endif /* #ifndef install_vtab */
+
+#endif /* _TKGLUE */
diff --git a/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h b/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h
new file mode 100644
index 00000000000..8255c08dc3f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tkGlue_f.h
@@ -0,0 +1,14 @@
+#ifndef TKGLUE_VT
+#define TKGLUE_VT
+typedef struct TkglueVtab
+{
+ unsigned (*tabSize)(void);
+#define VFUNC(type,name,mem,args) type (*mem) args;
+#define VVAR(type,name,mem) type (*mem);
+#include "tkGlue.t"
+#undef VFUNC
+#undef VVAR
+} TkglueVtab;
+extern TkglueVtab *TkglueVptr;
+extern TkglueVtab *TkglueVGet(void);
+#endif /* TKGLUE_VT */
diff --git a/Master/tlpkg/tlperl/lib/Tk/tranicon.gif b/Master/tlpkg/tlperl/lib/Tk/tranicon.gif
new file mode 100644
index 00000000000..dc7d494c572
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/tranicon.gif
Binary files differ
diff --git a/Master/tlpkg/tlperl/lib/Tk/typemap b/Master/tlpkg/tlperl/lib/Tk/typemap
new file mode 100644
index 00000000000..29138850ab3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/typemap
@@ -0,0 +1,96 @@
+TYPEMAP
+Tk_Window T_TK_WINDOW
+Tk_Image T_TK_IMAGE
+TkWindow * T_TKWINDOW
+Display * T_IVOBJ
+Screen * T_IVOBJ
+Visual * T_IVOBJ
+Window T_IVOBJ
+Colormap T_IVOBJ
+GC T_IVOBJ
+Font T_IVOBJ
+Atom T_IV
+HANDLE T_IV
+BOOL T_IV
+HWND T_TK_HWND
+FILE * T_NIO
+hash_ptr * T_PTR
+Tk_3DBorder T_IVOBJ
+Tk_Uid T_TK_UID
+Tcl_Interp * T_TK_INTERP
+Tk_Font T_TK_FONT
+EventAndKeySym * T_TK_XEVENT
+LangCallback * T_TK_CALLBACK
+LangFontInfo * T_PVOBJ
+const char * T_PV
+
+INPUT
+T_PVOBJ
+ if (sv_isobject($arg)) {
+ STRLEN sz;
+ $var = ($type) SvPV((SV*)SvRV($arg),sz);
+ if (sz != sizeof(*$var))
+ croak(\"$arg too small (%d) for $var $type (%d)\",sz,sizeof(*$var));
+ }
+ else
+ croak(\"$var is not an object\")
+
+T_TK_WINDOW
+ $var = SVtoWindow($arg)
+
+T_TK_CALLBACK
+ $var = LangMakeCallback($arg)
+
+
+T_TK_HWND
+ $var = SVtoHWND($arg)
+
+T_TK_XEVENT
+ $var = SVtoEventAndKeySym($arg)
+
+T_TK_FONT
+ $var = SVtoFont($arg)
+
+T_TK_IMAGE
+ $var = SVtoImage($arg)
+
+T_TKWINDOW
+ $var = (TkWindow *) SVtoWindow($arg)
+
+T_TK_INTERP
+ $var = WindowCommand($arg,NULL,1)->interp
+
+T_TK_UID
+ $var = Tk_GetUid(SvPV($arg,na))
+
+T_IVOBJ
+ if (sv_isa($arg, \"${ntype}\")) {
+ $var = INT2PTR($type, SvIV(SvRV($arg)));
+ }
+ else {
+ $var = ($type) NULL;
+ croak(\"$var is not of type ${ntype}\");
+ }
+
+T_NIO
+ if (sv_isa($arg, \"${Package}\")) {
+ $var = IoIFP(sv_2io(SvRV($arg)));
+ }
+ else
+ croak(\"$var is not of type ${Package}\")
+
+
+OUTPUT
+T_IVOBJ
+ sv_setref_iv($arg, \"${ntype}\", PTR2IV($var));
+
+T_TK_UID
+ sv_setpv($arg,$var);
+
+T_TK_WINDOW
+ SvSetMagicSV($arg,TkToWidget($var,NULL));
+
+T_TKWINDOW
+ SvSetMagicSV($arg,TkToWidget((Tk_Window) $var,NULL));
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/vtab.def b/Master/tlpkg/tlperl/lib/Tk/vtab.def
new file mode 100644
index 00000000000..7663df7d6f4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/vtab.def
@@ -0,0 +1,90 @@
+#define IMPORT_VTABLE(ptr,type,name) do { \
+ ptr = INT2PTR(type *,SvIV(get_sv(name,GV_ADDWARN|GV_ADD))); \
+ if ((*ptr->tabSize)() != sizeof(type)) { \
+ Perl_warn(aTHX_ "%s wrong size for %s",name,#type); \
+ } \
+ } while (0)
+
+#ifdef WIN32
+#define DECLARE_VTABLES \
+LangVtab *LangVptr; \
+TcldeclsVtab *TcldeclsVptr; \
+TkVtab *TkVptr; \
+TkdeclsVtab *TkdeclsVptr; \
+TkeventVtab *TkeventVptr; \
+TkglueVtab *TkglueVptr; \
+TkintVtab *TkintVptr; \
+TkintdeclsVtab *TkintdeclsVptr; \
+TkintplatdeclsVtab *TkintplatdeclsVptr;\
+TkintxlibdeclsVtab *TkintxlibdeclsVptr;\
+TkoptionVtab *TkoptionVptr; \
+TkplatdeclsVtab *TkplatdeclsVptr
+
+#define IMPORT_VTABLES do { \
+IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \
+IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \
+IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \
+IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \
+IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \
+IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \
+IMPORT_VTABLE(TkintplatdeclsVptr,TkintplatdeclsVtab,"Tk::TkintplatdeclsVtab"); \
+IMPORT_VTABLE(TkintxlibdeclsVptr,TkintxlibdeclsVtab,"Tk::TkintxlibdeclsVtab"); \
+IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \
+IMPORT_VTABLE(TkplatdeclsVptr , TkplatdeclsVtab,"Tk::TkplatdeclsVtab"); \
+} while (0)
+#else
+#define DECLARE_VTABLES \
+LangVtab *LangVptr; \
+TcldeclsVtab *TcldeclsVptr; \
+TkVtab *TkVptr; \
+TkdeclsVtab *TkdeclsVptr; \
+TkeventVtab *TkeventVptr; \
+TkglueVtab *TkglueVptr; \
+TkintVtab *TkintVptr; \
+TkintdeclsVtab *TkintdeclsVptr; \
+TkoptionVtab *TkoptionVptr; \
+XlibVtab *XlibVptr
+
+#define IMPORT_VTABLES do { \
+IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \
+IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \
+IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \
+IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \
+IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \
+IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \
+IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \
+IMPORT_VTABLE(XlibVptr , XlibVtab,"Tk::XlibVtab"); \
+} while (0)
+#endif
+#define DECLARE_TIX \
+TixVtab *TixVptr; \
+TixintVtab *TixintVptr
+
+#define IMPORT_TIX do { \
+IMPORT_VTABLE(TixVptr , TixVtab,"Tk::TixVtab"); \
+IMPORT_VTABLE(TixintVptr , TixintVtab,"Tk::TixintVtab"); \
+} while (0)
+#define DECLARE_PHOTO \
+ImgintVtab *ImgintVptr; \
+TkimgphotoVtab *TkimgphotoVptr
+
+#define IMPORT_PHOTO do { \
+IMPORT_VTABLE(ImgintVptr , ImgintVtab,"Tk::ImgintVtab"); \
+IMPORT_VTABLE(TkimgphotoVptr , TkimgphotoVtab,"Tk::TkimgphotoVtab"); \
+} while (0)
+#define DECLARE_EVENT \
+TkeventVtab *TkeventVptr
+
+#define IMPORT_EVENT do { \
+IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \
+} while (0)
+#define DECLARE_TIXXPM \
+TiximgxpmVtab *TiximgxpmVptr
+
+#define IMPORT_TIXXPM do { \
+IMPORT_VTABLE(TiximgxpmVptr , TiximgxpmVtab,"Tk::TiximgxpmVtab"); \
+} while (0)
diff --git a/Master/tlpkg/tlperl/lib/Tk/widgets.pm b/Master/tlpkg/tlperl/lib/Tk/widgets.pm
new file mode 100644
index 00000000000..0d628027810
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/widgets.pm
@@ -0,0 +1,21 @@
+package Tk::widgets;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/widgets.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ foreach (@_)
+ {
+ local $SIG{__DIE__} = \&Carp::croak;
+ # carp "$_ already loaded" if (exists $INC{"Tk/$_.pm"});
+ require "Tk/$_.pm";
+ }
+}
+
+1;
+__END__
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/win.xbm b/Master/tlpkg/tlperl/lib/Tk/win.xbm
new file mode 100644
index 00000000000..13c05e8c2d7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/win.xbm
@@ -0,0 +1,6 @@
+#define win.xbm_width 16
+#define win.xbm_height 16
+static char win.xbm_bits[] = {
+ 0xff, 0xff, 0x0d, 0xb0, 0xff, 0xff, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
+ 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80,
+ 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0xff, 0xff};
diff --git a/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm b/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm
new file mode 100644
index 00000000000..73fe734c6d0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/winfolder.xpm
@@ -0,0 +1,39 @@
+/* XPM */
+static char *winfolder[] = {
+/* width height num_colors chars_per_pixel */
+" 17 15 17 1",
+/* colors */
+" c none",
+". c #000000",
+"# c #808080",
+"a c #800000",
+"b c #808000",
+"c c #008000",
+"d c #008080",
+"e c #000080",
+"f c #800080",
+"g c #ffffff",
+"h c #c0c0c0",
+"i c #ff0000",
+"j c #ffff00",
+"k c #00ff00",
+"l c #00ffff",
+"m c #0000ff",
+"n c #ff00ff",
+/* pixels */
+" ",
+" ##### ",
+" #hjhjh# ",
+" #hjhjhjh###### ",
+" #gggggggggggg#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" #ghjhjhjhjhjh#. ",
+" #gjhjhjhjhjhj#. ",
+" ##############. ",
+" .............. ",
+" ",
+};
diff --git a/Master/tlpkg/tlperl/lib/Tk/wintext.xpm b/Master/tlpkg/tlperl/lib/Tk/wintext.xpm
new file mode 100644
index 00000000000..50b2d5587dd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/wintext.xpm
@@ -0,0 +1,42 @@
+/* XPM */
+static char *wintext[] = {
+/* width height num_colors chars_per_pixel */
+" 15 18 17 1",
+/* colors */
+" c None",
+". c #000000",
+"# c #808080",
+"a c #800000",
+"b c #808000",
+"c c #008000",
+"d c #008080",
+"e c #000080",
+"f c #800080",
+"g c #ffffff",
+"h c #c0c0c0",
+"i c #ff0000",
+"j c #ffff00",
+"k c #00ff00",
+"l c #00ffff",
+"m c #0000ff",
+"n c #ff00ff",
+/* pixels */
+" ",
+" . . . . . ",
+" .g#g#g#g#g. ",
+" #g.g.g.g.g.g. ",
+" #ggggggggggh. ",
+" #ggggggggggh. ",
+" #gg...g..ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #gg......ggh. ",
+" #ggggggggggh. ",
+" #ggggggggggh. ",
+" #hhhhhhhhhhh. ",
+" ........... ",
+" "
+};