summaryrefslogtreecommitdiff
path: root/Master/xemtex/perl/site/lib/Tk
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2005-12-28 00:07:27 +0000
committerKarl Berry <karl@freefriends.org>2005-12-28 00:07:27 +0000
commit30dd9f517c9c093ff3319061647a4555264f7914 (patch)
tree0d7a349bf99be5a42cc9c5a80a30f3b7136c4ccd /Master/xemtex/perl/site/lib/Tk
parent08ab8dce83f53b0f915cb66a37bbc8478b22c307 (diff)
trunk
git-svn-id: svn://tug.org/texlive/trunk@9 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/xemtex/perl/site/lib/Tk')
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Adjuster.pm435
-rw-r--r--Master/xemtex/perl/site/lib/Tk/After.pm88
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Bitmap.pm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Button.pm148
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Camel.xpm41
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Canvas.pm60
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Checkbutton.pm42
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Clipboard.pm110
-rw-r--r--Master/xemtex/perl/site/lib/Tk/CmdLine.pm954
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ColorEdit.xpm58
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ColorEditor.pm759
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Config.pm12
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Configure.pm69
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Derived.pm510
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Dialog.pm70
-rw-r--r--Master/xemtex/perl/site/lib/Tk/DialogBox.pm115
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Entry.pm517
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Event.pm13
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Event/IO.pm122
-rw-r--r--Master/xemtex/perl/site/lib/Tk/FBox.pm891
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Frame.pm373
-rw-r--r--Master/xemtex/perl/site/lib/Tk/IconList.pm536
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Image.pm73
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Label.pm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Listbox.pm856
-rw-r--r--Master/xemtex/perl/site/lib/Tk/MainWindow.pm188
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menu.pm1130
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menu/Item.pm180
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menubutton.pm398
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Optionmenu.pm110
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Pixmap.pm19
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Pretty.pm93
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ROText.pm36
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Radiobutton.pm45
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Scale.pm278
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Scrollbar.pm414
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Submethods.pm46
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Text.pm1600
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Text/Tag.pm46
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Tk.xbm44
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Tk.xpm41
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Toplevel.pm211
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Widget.pm1298
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Wm.pm165
-rw-r--r--Master/xemtex/perl/site/lib/Tk/X.pm398
-rw-r--r--Master/xemtex/perl/site/lib/Tk/X11/license.terms32
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Xcamel.gifbin0 -> 4193 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/act_folder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/act_folder.xpm22
-rw-r--r--Master/xemtex/perl/site/lib/Tk/anim.gifbin0 -> 2533 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/balArrow.xbm4
-rw-r--r--Master/xemtex/perl/site/lib/Tk/cbxarrow.xbm6
-rw-r--r--Master/xemtex/perl/site/lib/Tk/file.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/file.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/folder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/folder.xpm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/icon.gifbin0 -> 1924 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/license.terms35
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfile.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfolder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfolder.xpm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/prolog.ps284
-rw-r--r--Master/xemtex/perl/site/lib/Tk/srcfile.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/textfile.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/tranicon.gifbin0 -> 1718 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/widgets.pm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/win.xbm6
-rw-r--r--Master/xemtex/perl/site/lib/Tk/winfolder.xpm39
-rw-r--r--Master/xemtex/perl/site/lib/Tk/wintext.xpm42
69 files changed, 14243 insertions, 0 deletions
diff --git a/Master/xemtex/perl/site/lib/Tk/Adjuster.pm b/Master/xemtex/perl/site/lib/Tk/Adjuster.pm
new file mode 100644
index 00000000000..0fd5b4f765a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Adjuster.pm
@@ -0,0 +1,435 @@
+package Tk::Adjuster;
+
+use vars qw($VERSION);
+$VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Adjuster.pm#25 $
+
+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'};
+ $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/xemtex/perl/site/lib/Tk/After.pm b/Master/xemtex/perl/site/lib/Tk/After.pm
new file mode 100644
index 00000000000..e5eac8b20a8
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/After.pm
@@ -0,0 +1,88 @@
+# Copyright (c) 1995-1999 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 = '3.015'; # $Id: //depot/Tk8/Tk/After.pm#15 $
+
+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;
+ }
+}
+
+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} = ();
+}
+
+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);
+ 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;
+}
+
+1;
+__END__
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Bitmap.pm b/Master/xemtex/perl/site/lib/Tk/Bitmap.pm
new file mode 100644
index 00000000000..da563ffa6cb
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Bitmap.pm
@@ -0,0 +1,18 @@
+package Tk::Bitmap;
+require Tk;
+import Tk qw($XS_VERSION);
+require Tk::Image;
+
+use vars qw($VERSION);
+$VERSION = '3.010'; # $Id: //depot/Tk8/Bitmap/Bitmap.pm#10 $
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Bitmap';
+
+bootstrap Tk::Bitmap;
+
+sub Tk_image { 'bitmap' }
+
+1;
+__END__
diff --git a/Master/xemtex/perl/site/lib/Tk/Button.pm b/Master/xemtex/perl/site/lib/Tk/Button.pm
new file mode 100644
index 00000000000..b0983ead7c3
--- /dev/null
+++ b/Master/xemtex/perl/site/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-1999 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '3.014'; # $Id: //depot/Tk8/Tk/Button.pm#14 $
+
+# 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/xemtex/perl/site/lib/Tk/Camel.xpm b/Master/xemtex/perl/site/lib/Tk/Camel.xpm
new file mode 100644
index 00000000000..ba33c0149ec
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/Canvas.pm b/Master/xemtex/perl/site/lib/Tk/Canvas.pm
new file mode 100644
index 00000000000..e1ce78b6a93
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Canvas.pm
@@ -0,0 +1,60 @@
+package Tk::Canvas;
+use vars qw($VERSION);
+$VERSION = '3.018'; # $Id: //depot/Tk8/Canvas/Canvas.pm#18 $
+
+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;
+ }
+}
+
+
+
+1;
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Checkbutton.pm b/Master/xemtex/perl/site/lib/Tk/Checkbutton.pm
new file mode 100644
index 00000000000..e5c43f15f24
--- /dev/null
+++ b/Master/xemtex/perl/site/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-1999 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+
+use vars qw($VERSION);
+$VERSION = '3.011'; # $Id: //depot/Tk8/Tk/Checkbutton.pm#11 $
+
+# 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/xemtex/perl/site/lib/Tk/Clipboard.pm b/Master/xemtex/perl/site/lib/Tk/Clipboard.pm
new file mode 100644
index 00000000000..6990b371f58
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Clipboard.pm
@@ -0,0 +1,110 @@
+# Copyright (c) 1995-1999 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 = '3.016'; # $Id: //depot/Tk8/Tk/Clipboard.pm#16 $
+
+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 { $w->insert('insert',$w->clipboardGet)};
+}
+
+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/xemtex/perl/site/lib/Tk/CmdLine.pm b/Master/xemtex/perl/site/lib/Tk/CmdLine.pm
new file mode 100644
index 00000000000..09d4da9c41d
--- /dev/null
+++ b/Master/xemtex/perl/site/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 = '3.030'; # $Id: //depot/Tk8/Tk/CmdLine.pm#30 $
+
+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/xemtex/perl/site/lib/Tk/ColorEdit.xpm b/Master/xemtex/perl/site/lib/Tk/ColorEdit.xpm
new file mode 100644
index 00000000000..ef3474cd869
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/ColorEditor.pm b/Master/xemtex/perl/site/lib/Tk/ColorEditor.pm
new file mode 100644
index 00000000000..be4c373194a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/ColorEditor.pm
@@ -0,0 +1,759 @@
+package Tk::ColorSelect;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $
+
+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)));
+ }
+ 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 = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $
+
+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,
+ ],
+ );
+ $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) = @_;
+
+ $objref->deiconify;
+
+} # 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/xemtex/perl/site/lib/Tk/Config.pm b/Master/xemtex/perl/site/lib/Tk/Config.pm
new file mode 100644
index 00000000000..7c89d1aadb2
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Config.pm
@@ -0,0 +1,12 @@
+package Tk::Config;
+require Exporter;
+use base qw(Exporter);
+$VERSION = '800.024';
+$inc = '-I$(TKDIR)/pTk/mTk/xlib';
+$define = '';
+$xlib = '';
+$xinc = '';
+$gccopt = '';
+$win_arch = 'MSWin32';
+@EXPORT = qw($VERSION $inc $define $xlib $xinc $gccopt $win_arch);
+1;
diff --git a/Master/xemtex/perl/site/lib/Tk/Configure.pm b/Master/xemtex/perl/site/lib/Tk/Configure.pm
new file mode 100644
index 00000000000..5fc6e68ade6
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Configure.pm
@@ -0,0 +1,69 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '3.010'; # $Id: //depot/Tk8/Tk/Configure.pm#10 $
+
+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/xemtex/perl/site/lib/Tk/Derived.pm b/Master/xemtex/perl/site/lib/Tk/Derived.pm
new file mode 100644
index 00000000000..89310d4d77a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Derived.pm
@@ -0,0 +1,510 @@
+# Copyright (c) 1995-1999 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 = '3.046'; # $Id: //depot/Tk8/Tk/Derived.pm#46 $
+
+$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'}))
+ {
+ my (@bg) = ('SELF');
+ push(@bg,'CHILDREN') if $child;
+ $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
+ }
+ unless (exists($specs->{'-foreground'}))
+ {
+ my (@fg) = ('PASSIVE');
+ unshift(@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/xemtex/perl/site/lib/Tk/Dialog.pm b/Master/xemtex/perl/site/lib/Tk/Dialog.pm
new file mode 100644
index 00000000000..e277e35af7b
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Dialog.pm
@@ -0,0 +1,70 @@
+package Tk::Dialog;
+
+use vars qw($VERSION);
+$VERSION = '3.031'; # $Id: //depot/Tk8/Tk/Dialog.pm#31 $
+
+# 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/xemtex/perl/site/lib/Tk/DialogBox.pm b/Master/xemtex/perl/site/lib/Tk/DialogBox.pm
new file mode 100644
index 00000000000..33b4b85ed85
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/DialogBox.pm
@@ -0,0 +1,115 @@
+#
+# 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 = '3.032'; # $Id: //depot/Tk8/Tixish/DialogBox.pm#32 $
+
+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;
+ $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" } );
+ $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->bind('<Return>' => [ $b, 'Invoke']);
+ $cw->{'default_button'} = $b;
+ } 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],
+ );
+ $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->waitVariable(\$cw->{'selected_button'});
+ $cw->grabRelease;
+ $cw->withdraw;
+ $cw->Callback(-command => $cw->{'selected_button'});
+}
+
+sub Show {
+ my ($cw, $grab) = @_;
+ croak 'DialogBox: "Show" method requires at least 1 argument'
+ if scalar @_ < 1;
+ my $old_focus = $cw->focusSave;
+ my $old_grab = $cw->grabSave;
+
+ $cw->Popup();
+
+ Tk::catch {
+ if (defined $grab && length $grab && ($grab =~ /global/)) {
+ $cw->grabGlobal;
+ } else {
+ $cw->grab;
+ }
+ };
+ if (defined $cw->{'default_button'}) {
+ $cw->{'default_button'}->focus;
+ } else {
+ $cw->focus;
+ }
+ $cw->Wait;
+ &$old_focus;
+ &$old_grab;
+ return $cw->{'selected_button'};
+}
+
+1;
diff --git a/Master/xemtex/perl/site/lib/Tk/Entry.pm b/Master/xemtex/perl/site/lib/Tk/Entry.pm
new file mode 100644
index 00000000000..2696b496497
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Entry.pm
@@ -0,0 +1,517 @@
+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-1999 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '3.037'; # $Id: //depot/Tk8/Entry/Entry.pm#37 $
+
+# 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','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);
+
+ # Standard Motif bindings:
+ $mw->bind($class,'<Escape>','selectionClear');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x')]);
+
+ $mw->bind($class,'<B1-Motion>',['MouseSelect',Ev('x')]);
+
+ $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,'<ButtonRelease-1>','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');
+
+ $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');
+
+ $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']);
+
+ # A few additional bindings from John Ousterhout.
+ $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<2>','Button_2');
+ $mw->bind($class,'<B2-Motion>','B2_Motion');
+ $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->SelectionGet)}
+}
+
+
+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
+}
+
+
+sub B2_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if (abs(($Ev->x-$Tk::x)) > 2)
+ {
+ $Tk::mouseMoved = 1
+ }
+ $w->scan('dragto',$Ev->x)
+}
+
+
+sub ButtonRelease_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ eval
+ {local $SIG{__DIE__};
+ $w->insert('insert',$w->SelectionGet);
+ $w->SeeInsert;
+ }
+ }
+}
+
+# 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('@' . $x);
+ $w->selectionFrom('@' . $x);
+ $w->selectionClear;
+ if ($w->cget('-state') eq 'normal')
+ {
+ $w->focus()
+ }
+}
+# 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;
+ $Tk::selectMode = shift if (@_);
+ my $cur = $w->index('@' . $x);
+ return unless defined $cur;
+ my $anchor = $w->index('anchor');
+ return unless defined $anchor;
+ if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
+ {
+ $Tk::mouseMoved = 1
+ }
+ my $mode = $Tk::selectMode;
+ return unless $mode;
+ if ($mode eq 'char')
+ {
+ if ($Tk::mouseMoved)
+ {
+ if ($cur < $anchor)
+ {
+ $w->selectionTo($cur)
+ }
+ else
+ {
+ $w->selectionTo($cur+1)
+ }
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ 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;
+}
+# 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;
+ 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);
+ }
+}
+# 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;
+}
+
+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+1-$s);
+}
+
+1;
+
+__END__
+
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Event.pm b/Master/xemtex/perl/site/lib/Tk/Event.pm
new file mode 100644
index 00000000000..b162e475d4a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Event.pm
@@ -0,0 +1,13 @@
+package Tk::Event;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK);
+END { CleanupGlue() }
+$VERSION = '3.026'; # $Id: //depot/Tk8/Event/Event.pm#26 $
+$XS_VERSION = '800.024';
+require DynaLoader;
+use base qw(Exporter DynaLoader);
+@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
+bootstrap Tk::Event;
+require Tk::Event::IO;
+1;
+__END__
diff --git a/Master/xemtex/perl/site/lib/Tk/Event/IO.pm b/Master/xemtex/perl/site/lib/Tk/Event/IO.pm
new file mode 100644
index 00000000000..a28ae54147a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Event/IO.pm
@@ -0,0 +1,122 @@
+package Tk::Event::IO;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = '3.036'; # $Id: //depot/Tk8/Event/Event/IO.pm#12 $ +24
+
+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);
+ $obj = tie *$file,'Tk::Event::IO', $file unless $obj && $obj->isa('Tk::Event::IO');
+ if (@_ == 3)
+ {
+ return $obj->handler($imode);
+ }
+ else
+ {
+ my $h = $obj->handler($imode,$cb);
+ undef $obj;
+ untie *$file unless $h;
+ }
+}
+
+1;
+__END__
diff --git a/Master/xemtex/perl/site/lib/Tk/FBox.pm b/Master/xemtex/perl/site/lib/Tk/FBox.pm
new file mode 100644
index 00000000000..bcc6ef1bf21
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/FBox.pm
@@ -0,0 +1,891 @@
+# -*- 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 perk/Tk by Slaven Rezic <eserte@cs.tu-berlin.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 = '3.020'; # $Id: //depot/Tk8/Tk/FBox.pm#20 $
+
+use base qw(Tk::Toplevel);
+
+Construct Tk::Widget 'FBox';
+
+my $selectFilePath;
+my $selectFile;
+my $selectPath;
+
+sub import {
+ if (defined $_[1] and $_[1] eq 'as_default') {
+ local $^W = 0;
+ package Tk;
+ *FDialog = \&Tk::FBox::FDialog;
+ *MotifFDialog = \&Tk::FBox::FDialog;
+ }
+}
+
+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) {
+ $updirImage = $w->Bitmap(-data => "#define updir_width 28\n" .
+ "#define updir_height 16\n" .
+ <<EOF);
+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);
+ $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(-browsecmd => ['ListBrowse', $w],
+ -command => ['ListInvoke', $w],
+ );
+
+ # f2: the frame with the OK button and the "file name" field
+ my $f2 = $w->Frame(-bd => 0);
+ 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),
+ );
+ $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],
+ -title => ['PASSIVE', undef, undef, undef],
+ -type => ['PASSIVE', undef, undef, 'open'],
+ -filter => ['PASSIVE', undef, undef, '*'],
+ -force => ['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;
+}
+
+
+sub Show {
+ my $w = shift;
+
+ $w->configure(@_);
+
+ $w->transient($w->Parent);
+
+ # set the default directory and selection according to the -initial
+ # settings
+ {
+ my $initialdir = $w->cget(-initialdir);
+ if (defined $initialdir) {
+ if (-d $initialdir) {
+ $w->{'selectPath'} = $initialdir;
+ } else {
+ $w->Error("\"$initialdir\" is not a valid directory");
+ }
+ }
+ $w->{'selectFile'} = $w->cget(-initialfile);
+ }
+
+ # 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 {
+ $w->configure(-filter => '*');
+ $typeMenuBtn->configure(-state => 'disabled',
+ -takefocus => 0);
+ $typeMenuLab->configure(-state => 'disabled');
+ }
+ $w->UpdateWhenIdle;
+
+ # 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;
+ 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");
+
+ {
+ my $title = $w->cget(-title);
+ if (!defined $title) {
+ $title = ($w->cget(-type) eq 'open' ? 'Open' : 'Save As');
+ }
+ $w->title($title);
+ }
+
+ $w->deiconify;
+ # Set a grab and claim the focus too.
+ 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');
+ $ent->insert(0, $w->{'selectFile'});
+ $ent->selectionFrom(0);
+ $ent->selectionTo('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(\$selectFilePath);
+ eval {
+ $oldFocus->focus if $oldFocus;
+ };
+ if (Tk::Exists($w)) { # widget still exists
+ $w->grabRelease;
+ $w->withdraw;
+ }
+ if ($oldGrab) {
+ if ($grabStatus eq 'global') {
+ $oldGrab->grabGlobal;
+ } else {
+ $oldGrab->grab;
+ }
+ }
+ return $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) {
+ require Tk::Pixmap;
+ $folderImage = $w->Pixmap(-file => Tk->findINC('folder.xpm'));
+ $fileImage = $w->Pixmap(-file => Tk->findINC('file.xpm'));
+ }
+ my $folder = $folderImage;
+ my $file = $fileImage;
+ 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 $flt = join('|', split(' ', $w->cget(-filter)) );
+ $flt =~ s!([\.\+])!\\$1!g;
+ $flt =~ s!\*!.*!g;
+ local *FDIR;
+ if( opendir( FDIR, _cwd() )) {
+ my @files;
+ foreach my $f (sort { lc($a) cmp lc($b) } readdir FDIR) {
+ next if $f eq '.' or $f eq '..';
+ if (-d $f) { $icons->Add($folder, $f); }
+ elsif( $f =~ m!$flt$! ) { push( @files, $f ); }
+ }
+ closedir( FDIR );
+ foreach my $f ( @files ) { $icons->Add($file, $f); }
+ }
+
+ $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
+#
+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);
+ $path = "$path$defaultext" if ($path !~ /\..+$/) and defined $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->selectionFrom(0);
+ $ent->selectionTo('end');
+ $ent->icursor('end');
+ } else {
+ $ent->selectionClear;
+ }
+ $w->{'icons'}->Unselect;
+ my $okBtn = $w->{'okBtn'};
+ if ($w->cget(-type) eq 'open') {
+ $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;
+ $text =~ s/^\s+//;
+ $text =~ s/\s+$//;
+ my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text,
+ $w->cget(-defaultextension));
+ 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);
+ $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->selection('from', 0);
+ $ent->selection('to', 'end');
+ $ent->icursor('end');
+ } else {
+ $w->SetPathSilently($path);
+ $w->{'selectFile'} = $file;
+ $w->Done;
+ }
+ } elsif ($flag eq 'PATH') {
+ $w->messageBox(-icon => 'warning',
+ -type => 'OK',
+ -message => "Directory \'$path\' does not exist.");
+ $ent->selection('from', 0);
+ $ent->selection('to', 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'CHDIR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Cannot change to the directory \"$path\".\nPermission denied.",
+ -icon => 'warning');
+ $ent->selection('from', 0);
+ $ent->selection('to', 'end');
+ $ent->icursor('end');
+ } elsif ($flag eq 'ERROR') {
+ $w->messageBox(-type => 'OK',
+ -message => "Invalid file name \"$path\".",
+ -icon => 'warning');
+ $ent->selection('from', 0);
+ $ent->selection('to', '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 $text = $w->{'icons'}->Get;
+ if (defined $text and $text ne '') {
+ my $file = JoinFile($w->{'selectPath'}, $text);
+ if (-d $file) {
+ $w->ListInvoke($text);
+ return;
+ }
+ }
+ $w->ActivateEnt;
+}
+
+# Gets called when user presses the "Cancel" button
+#
+sub CancelCmd {
+ undef $selectFilePath;
+}
+
+# Gets called when user browses the IconList widget (dragging mouse, arrow
+# keys, etc)
+#
+sub ListBrowse {
+ my($w, $text) = @_;
+ return if ($text eq '');
+ my $file = JoinFile($w->{'selectPath'}, $text);
+ my $ent = $w->{'ent'};
+ my $okBtn = $w->{'okBtn'};
+ unless (-d $file) {
+ $ent->delete(0, 'end');
+ $ent->insert(0, $text);
+ if ($w->cget(-type) eq 'open') {
+ $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, $text) = @_;
+ return if ($text eq '');
+ my $file = JoinFile($w->{'selectPath'}, $text);
+ 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 {
+ $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 '') {
+ $_selectFilePath = JoinFile($w->{'selectPath'}, $w->{'selectFile'});
+ if (-e $_selectFilePath and
+ $w->cget(-type) eq 'save' 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');
+ }
+ }
+ $selectFilePath = ($_selectFilePath ne '' ? $_selectFilePath : undef);
+}
+
+sub FDialog {
+ my $cmd = shift;
+ if ($cmd =~ /Save/) {
+ push @_, -type => 'save';
+ }
+ 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;
+}
+
+1;
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Frame.pm b/Master/xemtex/perl/site/lib/Tk/Frame.pm
new file mode 100644
index 00000000000..b80937b8189
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Frame.pm
@@ -0,0 +1,373 @@
+# Copyright (c) 1995-1999 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 = '3.031'; # $Id: //depot/Tk8/Tk/Frame.pm#31 $
+
+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 Populate
+{
+ my ($cw,$args) = @_;
+ $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/xemtex/perl/site/lib/Tk/IconList.pm b/Master/xemtex/perl/site/lib/Tk/IconList.pm
new file mode 100644
index 00000000000..1c83e740887
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/IconList.pm
@@ -0,0 +1,536 @@
+# -*- 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 by Slaven Rezic <eserte@cs.tu-berlin.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 strict;
+
+use vars qw($VERSION);
+$VERSION = '3.005'; # $Id: //depot/Tk8/Tk/IconList.pm#5 $
+
+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,
+ );
+ my $canvas = $w->Component('Canvas' => 'canvas',
+ -bd => 2,
+ -relief => 'sunken',
+ -width => 400,
+ -height => 120,
+ -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;
+ delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+
+ # Creates the event bindings.
+ $canvas->Tk::bind('<Configure>', sub { $w->Arrange } );
+ $canvas->Tk::bind('<1>',
+ sub {
+ my $c = shift;
+ my $Ev = $c->XEvent;
+ $w->Btn1($Ev->x, $Ev->y);
+ }
+ );
+ $canvas->Tk::bind('<B1-Motion>',
+ sub {
+ my $c = shift;
+ my $Ev = $c->XEvent;
+ $w->Motion1($Ev->x, $Ev->y);
+ }
+ );
+ $canvas->Tk::bind('<Double-ButtonRelease-1>',
+ sub {
+ my $c = shift;
+ my $Ev = $c->XEvent;
+ $w->Double1($Ev->x,$Ev->y);
+ }
+ );
+ $canvas->Tk::bind('<ButtonRelease-1>', sub { $w->CancelRepeat });
+ $canvas->Tk::bind('<B1-Leave>',
+ sub {
+ my $c = shift;
+ my $Ev = $c->XEvent;
+ $w->Leave1($Ev->x, $Ev->y);
+ }
+ );
+ $canvas->Tk::bind('<B1-Enter>', sub { $w->CancelRepeat });
+ $canvas->Tk::bind('<Up>', sub { $w->UpDown(-1) });
+ $canvas->Tk::bind('<Down>', sub { $w->UpDown(1) });
+ $canvas->Tk::bind('<Left>', sub { $w->LeftRight(-1) });
+ $canvas->Tk::bind('<Right>', sub { $w->LeftRight(1) });
+ $canvas->Tk::bind('<Return>', sub { $w->ReturnKey });
+ $canvas->Tk::bind('<KeyPress>',
+ sub {
+ my $c = shift;
+ my $Ev = $c->XEvent;
+ $w->KeyPress($Ev->A);
+ }
+ );
+ $canvas->Tk::bind('<Control-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp');
+ $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn });
+
+ $w->ConfigSpecs(-browsecmd =>
+ ['CALLBACK', 'browseCommand', 'BrowseCommand', undef],
+ -command =>
+ ['CALLBACK', 'command', 'Command', undef],
+ -font =>
+ ['PASSIVE', 'font', 'Font', undef],
+ -foreground =>
+ ['PASSIVE', 'foreground', 'Foreground', undef],
+ -fg => '-foreground',
+ );
+
+ $w;
+}
+
+# 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;
+ delete $w->{'curItem'};
+ $w->{'noScroll'} = 1;
+ $w->Subwidget('sbar')->set(0.0, 1.0);
+ $canvas->xview('moveto', 0);
+}
+
+# Adds an icon into the IconList with the designated image and text
+#
+sub Add {
+ my($w, $image, $text) = @_;
+ my $canvas = $w->Subwidget('canvas');
+ my $iTag = $canvas->createImage(0, 0, -image => $image, -anchor => 'nw');
+ my $font = $w->cget(-font);
+ my $fg = $w->cget(-foreground);
+ my $tTag = $canvas->createText(0, 0, -text => $text, -anchor => 'nw',
+ (defined $fg ? (-fill => $fg) : ()),
+ (defined $font ? (-font => $font) : ()),
+ );
+ my $rTag = $canvas->createRectangle(0, 0, 0, 0,
+ -fill => undef,
+ -outline => undef);
+ 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($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'} = ($H - $pad) / $dy;
+ $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1);
+ $w->Select($w->{'list'}[$w->{'curItem'}][2], 0)
+ if (exists $w->{'curItem'});
+}
+
+# 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 (exists $w->{'selected'});
+}
+
+# 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 unless (exists $w->{'itemList'}{$rTag});
+ my $canvas = $w->Subwidget('canvas');
+ my(@sRegion) = @{ $canvas->cget('-scrollregion') };
+ return unless (@sRegion);
+ my(@bbox) = $canvas->bbox($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 SelectAtXY {
+ my($w, $x, $y) = @_;
+ my $canvas = $w->Subwidget('canvas');
+ $w->Select($canvas->find('closest',
+ $canvas->canvasx($x),
+ $canvas->canvasy($y)));
+}
+
+sub Select {
+ my $w = shift;
+ my $rTag = shift;
+ my $callBrowse = (@_ ? shift : 1);
+ return unless (exists $w->{'itemList'}{$rTag});
+ my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
+ my $canvas = $w->Subwidget('canvas');
+ $w->{'rect'} = $canvas->createRectangle(0, 0, 0, 0, -fill => '#a0a0ff',
+ -outline => '#a0a0ff')
+ unless (exists $w->{'rect'});
+ $canvas->lower($w->{'rect'});
+ my(@bbox) = $canvas->bbox($tTag);
+ $canvas->coords($w->{'rect'}, @bbox);
+ $w->{'curItem'} = $serial;
+ $w->{'selected'} = $text;
+ if ($callBrowse) {
+ $w->Callback(-browsecmd => $text);
+ }
+}
+
+sub Unselect {
+ my $w = shift;
+ my $canvas = $w->Subwidget('canvas');
+ if (exists $w->{'rect'}) {
+ $canvas->delete($w->{'rect'});
+ delete $w->{'rect'};
+ }
+ delete $w->{'selected'} if (exists $w->{'selected'});
+ delete $w->{'curItem'};
+}
+
+# Returns the selected item
+#
+sub Get {
+ my $w = shift;
+ if (exists $w->{'selected'}) {
+ $w->{'selected'};
+ } else {
+ undef;
+ }
+}
+
+sub Btn1 {
+ my($w, $x, $y) = @_;
+ $w->Subwidget('canvas')->focus;
+ $w->SelectAtXY($x, $y);
+}
+
+# Gets called on button-1 motions
+#
+sub Motion1 {
+ my($w, $x, $y) = @_;
+ $Tk::x = $x;
+ $Tk::y = $y;
+ $w->SelectAtXY($x, $y);
+}
+
+sub Double1 {
+ my($w, $x, $y) = @_;
+ $w->Invoke if (exists $w->{'curItem'});
+}
+
+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'});
+ unless (exists $w->{'curItem'}) {
+ my $rTag = $w->{'list'}[0][2];
+ $w->Select($rTag);
+ }
+}
+
+# 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) = @_;
+ my $rTag;
+ return unless (exists $w->{'list'});
+ unless (exists $w->{'curItem'}) {
+ $rTag = $w->{'list'}[0][2];
+ } else {
+ my $oldRTag = $w->{'list'}[$w->{'curItem'}][2];
+ $rTag = $w->{'list'}[($w->{'curItem'} + $amount)][2];
+ $rTag = $oldRTag unless defined $rTag;
+ }
+ if (defined $rTag) {
+ $w->Select($rTag);
+ $w->See($rTag);
+ }
+}
+
+# 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) = @_;
+ my $rTag;
+ return unless (exists $w->{'list'});
+ unless (exists $w->{'curItem'}) {
+ $rTag = $w->{'list'}[0][2];
+ } else {
+ my $oldRTag = $w->{'list'}[$w->{'curItem'}][2];
+ my $newItem = $w->{'curItem'} + $amount * $w->{'itemsPerColumn'};
+ $rTag = $w->{'list'}[$newItem][2];
+ $rTag = $oldRTag unless (defined $rTag);
+ }
+ if (defined $rTag) {
+ $w->Select($rTag);
+ $w->See($rTag);
+ }
+}
+
+#----------------------------------------------------------------------
+# 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 '');
+ my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'});
+ $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) {
+ my $rTag = $w->{'list'}[$theIndex][2];
+ $w->Select($rTag, 0);
+ $w->See($rTag);
+ }
+}
+
+sub Reset {
+ my $w = shift;
+ undef $w->{'_ILAccel'};
+}
+
+1;
diff --git a/Master/xemtex/perl/site/lib/Tk/Image.pm b/Master/xemtex/perl/site/lib/Tk/Image.pm
new file mode 100644
index 00000000000..f6d6634c05b
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Image.pm
@@ -0,0 +1,73 @@
+# Copyright (c) 1995-1999 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 = '3.014'; # $Id: //depot/Tk8/Tk/Image.pm#14 $
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ $package->InitClass($widget);
+ my $leaf = $package->Tk_image;
+ my $obj = $widget->Tk::image('create',$leaf,@_);
+ 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/xemtex/perl/site/lib/Tk/Label.pm b/Master/xemtex/perl/site/lib/Tk/Label.pm
new file mode 100644
index 00000000000..e320e193846
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Label.pm
@@ -0,0 +1,21 @@
+# Copyright (c) 1995-1999 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 = '3.011'; # $Id: //depot/Tk8/Tk/Label.pm#11 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Label';
+
+sub Tk_cmd { \&Tk::label }
+
+1;
+
+
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Listbox.pm b/Master/xemtex/perl/site/lib/Tk/Listbox.pm
new file mode 100644
index 00000000000..0dd86c1ef2e
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Listbox.pm
@@ -0,0 +1,856 @@
+# 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);
+$VERSION = '3.033'; # $Id: //depot/Tk8/Listbox/Listbox.pm#33 $
+
+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','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;
+ 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>',['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')]);
+ return $class;
+}
+
+
+
+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];
+ }
+ }
+}
+
+# ----
+
+1;
+__END__
+
+#
+# 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)
+}
+
+
+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);
+ @Selection = ();
+ $Prev = $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($Prev) && $el == $Prev)
+ {
+ return;
+ }
+ $anchor = $w->index('anchor');
+ my $mode = $w->cget('-selectmode');
+ if ($mode eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet($el);
+ $Prev = $el;
+ }
+ elsif ($mode eq 'extended')
+ {
+ $i = $Prev;
+ 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(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += 1
+ }
+ while ($i > $el && $i > $anchor)
+ {
+ if (Tk::lsearch(\@Selection,$i) >= 0)
+ {
+ $w->selectionSet($i)
+ }
+ $i += -1
+ }
+ $Prev = $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 ($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')
+ {
+ @Selection = $w->curselection();
+ $Prev = $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');
+ $LNet__0 = $w->cget('-selectmode');
+ if ($LNet__0 eq 'browse')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active')
+ }
+ elsif ($LNet__0 eq 'extended')
+ {
+ $w->selectionClear(0,'end');
+ $w->selectionSet('active');
+ $w->selectionAnchor('active');
+ $Prev = $w->index('active');
+ @Selection = ();
+ }
+}
+# 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;
+ $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;
+ }
+ $first = $w->index('anchor');
+ $last = $Prev;
+ if ($first > $last)
+ {
+ $tmp = $first;
+ $first = $last;
+ $last = $tmp
+ }
+ $w->selectionClear($first,$last);
+ while ($first <= $last)
+ {
+ if (Tk::lsearch(\@Selection,$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 $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/xemtex/perl/site/lib/Tk/MainWindow.pm b/Master/xemtex/perl/site/lib/Tk/MainWindow.pm
new file mode 100644
index 00000000000..2be63f90358
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/MainWindow.pm
@@ -0,0 +1,188 @@
+# Copyright (c) 1995-1999 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 = '3.047'; # $Id: //depot/Tk8/Tk/MainWindow.pm#47 $
+
+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');
+ $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
+ catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
+ $mw->bind('all','<<LeftTab>>','focusPrev');
+ if ($Tk::platform eq 'unix')
+ {
+ $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[<<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>]);
+ }
+ else
+ {
+ $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>]);
+ }
+
+ # 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 ($pid == $$)
+ {
+ 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/xemtex/perl/site/lib/Tk/Menu.pm b/Master/xemtex/perl/site/lib/Tk/Menu.pm
new file mode 100644
index 00000000000..409467e0e24
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Menu.pm
@@ -0,0 +1,1130 @@
+# 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 = '3.045'; # $Id: //depot/Tk8/Tk/Menu.pm#45 $
+
+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);
+ 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->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,'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 = $menu->cget('-title');
+ unless (defined $title && length($title))
+ {
+ $parent = $w->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).
+ $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 dst.
+# dst - Name to use for topmost menu in duplicate
+# hierarchy.
+sub MenuDup
+{
+ my $src = shift;
+ my $parent = shift;
+ my $type = (@_) ? shift : 'normal';
+ my %args = (-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);
+ if ($type eq 'tearoff')
+ {
+ $dst->transient($parent->MainWindow);
+ }
+ 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;
+ my $path = $src->PathName;
+ foreach (@bindtags)
+ {
+ $_ = $dst if ($_ eq $path);
+ }
+ $dst->bindtags([@bindtags]);
+ foreach my $event ($src->bind)
+ {
+ my $cb = $src->bind($event);
+ $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/xemtex/perl/site/lib/Tk/Menu/Item.pm b/Master/xemtex/perl/site/lib/Tk/Menu/Item.pm
new file mode 100644
index 00000000000..ab341ebaf84
--- /dev/null
+++ b/Master/xemtex/perl/site/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 = '3.027'; # $Id: //depot/Tk8/Tk/Menu/Item.pm#27 $
+
+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/xemtex/perl/site/lib/Tk/Menubutton.pm b/Master/xemtex/perl/site/lib/Tk/Menubutton.pm
new file mode 100644
index 00000000000..ef9237900b2
--- /dev/null
+++ b/Master/xemtex/perl/site/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 = '3.025'; # $Id: //depot/Tk8/Menubutton/Menubutton.pm#25 $
+
+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/xemtex/perl/site/lib/Tk/Optionmenu.pm b/Master/xemtex/perl/site/lib/Tk/Optionmenu.pm
new file mode 100644
index 00000000000..ca3f5dba22a
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Optionmenu.pm
@@ -0,0 +1,110 @@
+# Copyright (c) 1995-1999 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 vars qw($VERSION);
+$VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Optionmenu.pm#25 $
+
+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 $var = delete $args->{-textvariable};
+ unless (defined $var)
+ {
+ my $gen = undef;
+ $var = \$gen;
+ }
+ my $menu = $w->menu(-tearoff => 0);
+ $w->configure(-textvariable => $var);
+
+ # 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],
+
+ -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.
+ $w->configure(-variable => $var) if ($var = delete $args->{-variable});
+ $w->configure(-command => $var) if ($var = delete $args->{-command});
+}
+
+sub setOption
+{
+ my ($w, $label, $val) = @_;
+ $val = $label if @_ == 2;
+ my $var = $w->cget(-textvariable);
+ $$var = $label;
+ $var = $w->cget(-variable);
+ $$var = $val if $var;
+ $w->Callback(-command => $val);
+}
+
+sub addOptions
+{
+ my $w = shift;
+ my $menu = $w->menu;
+ my $var = $w->cget(-textvariable);
+ my $old = $$var;
+ my $width = $w->cget('-width');
+ my %hash;
+ my $first;
+ while (@_)
+ {
+ my $val = shift;
+ my $label = $val;
+ if (ref $val)
+ {
+ ($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($old) || !exists($hash{$old}))
+ {
+ $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/xemtex/perl/site/lib/Tk/Pixmap.pm b/Master/xemtex/perl/site/lib/Tk/Pixmap.pm
new file mode 100644
index 00000000000..081b17f7892
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Pixmap.pm
@@ -0,0 +1,19 @@
+package Tk::Pixmap;
+
+use vars qw($VERSION);
+$VERSION = '3.011'; # $Id: //depot/Tk8/TixPixmap/Pixmap.pm#11 $
+
+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/xemtex/perl/site/lib/Tk/Pretty.pm b/Master/xemtex/perl/site/lib/Tk/Pretty.pm
new file mode 100644
index 00000000000..409f1e1b320
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Pretty.pm
@@ -0,0 +1,93 @@
+# Copyright (c) 1995-1999 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 = '3.013'; # $Id: //depot/Tk8/Tk/Pretty.pm#13 $
+
+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/xemtex/perl/site/lib/Tk/ROText.pm b/Master/xemtex/perl/site/lib/Tk/ROText.pm
new file mode 100644
index 00000000000..96fa1e070d3
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/ROText.pm
@@ -0,0 +1,36 @@
+# Copyright (c) 1995-1999 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 = '3.024'; # $Id: //depot/Tk8/Tk/ROText.pm#24 $
+
+use Tk::Text;
+use base qw(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 Tk::Widget::ScrlROText { shift->Scrolled('ROText' => @_) }
+
+1;
+
+__END__
+
diff --git a/Master/xemtex/perl/site/lib/Tk/Radiobutton.pm b/Master/xemtex/perl/site/lib/Tk/Radiobutton.pm
new file mode 100644
index 00000000000..a706de6675e
--- /dev/null
+++ b/Master/xemtex/perl/site/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-1999 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 = '3.013'; # $Id: //depot/Tk8/Tk/Radiobutton.pm#13 $
+
+# 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/xemtex/perl/site/lib/Tk/Scale.pm b/Master/xemtex/perl/site/lib/Tk/Scale.pm
new file mode 100644
index 00000000000..f31a68d9cb0
--- /dev/null
+++ b/Master/xemtex/perl/site/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 = '3.012'; # $Id: //depot/Tk8/Scale/Scale.pm#12 $
+
+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/xemtex/perl/site/lib/Tk/Scrollbar.pm b/Master/xemtex/perl/site/lib/Tk/Scrollbar.pm
new file mode 100644
index 00000000000..a828682514f
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Scrollbar.pm
@@ -0,0 +1,414 @@
+# Conversion from Tk4.0 scrollbar.tcl competed.
+package Tk::Scrollbar;
+require Tk;
+import Tk qw($XS_VERSION);
+use AutoLoader;
+
+use vars qw($VERSION);
+$VERSION = '3.014'; # $Id: //depot/Tk8/Scrollbar/Scrollbar.pm#14 $
+
+use base qw(Tk::Widget);
+
+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');
+ $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');
+ $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]);
+
+ $mw->bind($class, '<Home>', ['ScrlToPos', 0]);
+ $mw->bind($class, '<End>', ['ScrlToPos', 1]);
+
+ 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 = shift;
+ my $x = shift;
+ my $y = shift;
+ return unless (defined ($w->cget('-command')));
+ $initMouse = $w->fraction($x,$y);
+ @initValues = $w->get();
+ if (@initValues == 2)
+ {
+ $initPos = $initValues[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 = shift;
+ my $e = $w->XEvent;
+ return unless (defined $initMouse);
+ my $f = $w->fraction($e->x,$e->y);
+ my $delta = $f - $initMouse;
+ if ($w->cget('-jump'))
+ {
+ if (@initValues == 2)
+ {
+ $w->set($initValues[0]+$delta,$initValues[1]+$delta);
+ }
+ else
+ {
+ $delta = int($delta * $initValues[0]);
+ $initValues[2] += $delta;
+ $initValues[3] += $delta;
+ $w->set(@initValues);
+ }
+ }
+ 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 = shift;
+ my $x = shift;
+ my $y = shift;
+ return unless defined($initMouse);
+ if ($w->cget('-jump'))
+ {
+ $w->ScrlToPos($initPos + $w->fraction($x,$y) - $initMouse);
+ }
+ undef $initMouse;
+}
+
+# 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/xemtex/perl/site/lib/Tk/Submethods.pm b/Master/xemtex/perl/site/lib/Tk/Submethods.pm
new file mode 100644
index 00000000000..3c3abcea379
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Submethods.pm
@@ -0,0 +1,46 @@
+package Tk::Submethods;
+
+use vars qw($VERSION);
+$VERSION = '3.014'; # $Id: //depot/Tk8/Tk/Submethods.pm#14 $
+
+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/xemtex/perl/site/lib/Tk/Text.pm b/Master/xemtex/perl/site/lib/Tk/Text.pm
new file mode 100644
index 00000000000..c4b4f162f77
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Text.pm
@@ -0,0 +1,1600 @@
+# 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-1999 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 = '3.044'; # $Id: //depot/Tk8/Text/Text.pm#44 $
+
+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',
+ '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)],
+ );
+
+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')] );
+
+ 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');
+ }
+ $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)=@_;
+ 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;
+ 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);
+
+ my $button_find = $pop->Button(text=>'Find',
+ command => sub {$w->FindNext ($direction,$mode,$case,$find_entry->get()),} )
+ -> pack(-anchor=>'nw');
+
+ $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);}
+ }
+
+ my ($replace_entry,$button_replace,$button_replace_all);
+ unless ($find_only)
+ {
+ ######################################################
+ $replace_entry = $pop->Entry(width=>25);
+ ######################################################
+ $button_replace = $pop->Button(text=>'Replace',
+ command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
+ -> pack(-anchor=>'nw');
+
+ $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
+ }
+
+ ######################################################
+ $pop->Label(text=>" ")->pack();
+ ######################################################
+ unless ($find_only)
+ {
+ $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_find_all = $pop->Button(text=>'Find All',
+ command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
+ ->pack(-side => 'left');
+
+ my $button_cancel = $pop->Button(text=>'Cancel',
+ command => sub {$pop->destroy()} )
+ ->pack(-side => 'left');
+
+ $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 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.
+#
+# 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_old
+{
+ my ($w,$n) = @_;
+ my $i = $w->index('insert');
+ my ($line,$char) = split(/\./,$i);
+ if (!defined($Tk::prevPos) || $Tk::prevPos ne $i)
+ {
+ $Tk::char = $char
+ }
+ my $new = $w->index($line+$n . '.' . $Tk::char);
+ if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
+ {
+ $new = $i
+ }
+ $Tk::prevPos = $new;
+ return $new;
+}
+
+sub UpDownLine
+{
+ my ($w,$n) = @_;
+ my $i = $w->index('insert');
+ my ($line,$char) = split(/\./,$i);
+ my $string = $w->get($line.'.0', $i);
+
+ $string = expand($string);
+ $char=length($string);
+ $line += $n;
+
+ $string = $w->get($line.'.0', $line.'.0 lineend');
+ $string = expand($string);
+ $string = substr($string, 0, $char);
+
+ $string = unexpand($string);
+ $char = length($string);
+
+ my $new = $w->index($line . '.' . $char);
+ if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
+ {
+ $new = $i
+ }
+ $Tk::prevPos = $new;
+ $Tk::char = $char;
+ return $new;
+}
+
+
+# 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/xemtex/perl/site/lib/Tk/Text/Tag.pm b/Master/xemtex/perl/site/lib/Tk/Text/Tag.pm
new file mode 100644
index 00000000000..7cddf48fd25
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Text/Tag.pm
@@ -0,0 +1,46 @@
+package Tk::Text::Tag;
+require Tk::Text;
+
+use overload '""' => \&name;
+
+
+use vars qw($VERSION);
+$VERSION = '3.007'; # $Id: //depot/Tk8/Text/Text/Tag.pm#7 $
+
+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/xemtex/perl/site/lib/Tk/Tk.xbm b/Master/xemtex/perl/site/lib/Tk/Tk.xbm
new file mode 100644
index 00000000000..136d4793037
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/Tk.xpm b/Master/xemtex/perl/site/lib/Tk/Tk.xpm
new file mode 100644
index 00000000000..7880a637f39
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/Toplevel.pm b/Master/xemtex/perl/site/lib/Tk/Toplevel.pm
new file mode 100644
index 00000000000..1d7533f8377
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Toplevel.pm
@@ -0,0 +1,211 @@
+# Copyright (c) 1995-1999 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 = '3.028'; # $Id: //depot/Tk8/Tk/Toplevel.pm#28 $
+
+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/xemtex/perl/site/lib/Tk/Widget.pm b/Master/xemtex/perl/site/lib/Tk/Widget.pm
new file mode 100644
index 00000000000..811d9e5e28b
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Widget.pm
@@ -0,0 +1,1298 @@
+# Copyright (c) 1995-1999 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 = '3.080'; # $Id: //depot/Tk8/Tk/Widget.pm#80 $
+
+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 Listbox;
+sub Menu;
+sub Menubutton;
+sub Message;
+sub Scale;
+sub Scrollbar;
+sub Radiobutton;
+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)]
+ );
+
+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 scaling)]);
+
+
+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);
+ push(@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 $@;
+ 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;
+
+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) && $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 afterIdle
+{
+ my $w = shift;
+ return Tk::After->new($w,'idle','once',@_);
+}
+
+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 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 $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;
+}
+
+sub _busy
+{
+ my ($w,$f) = @_;
+ $w->bell if $f;
+ $w->break;
+}
+
+sub Unbusy
+{
+ my ($w) = @_;
+ $w->update;
+ $w->grabRelease;
+ my $old = delete $w->{'Busy'};
+ if (defined $old)
+ {
+ local $SIG{'__DIE__'};
+ eval { &{pop(@$old)} } while (@$old);
+ }
+ $w->update;
+}
+
+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]);
+}
+
+sub PriorNextBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']);
+ $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']);
+}
+
+sub YscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->PriorNextBind($class);
+ $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<Down>', ['yview','scroll',1,'units']);
+}
+
+sub XYscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->YscrollBind($class);
+ $mw->XscrollBind($class);
+}
+
+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) = @_;
+ # 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;
+ }
+}
+
+
+
+1;
+__END__
+
+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/xemtex/perl/site/lib/Tk/Wm.pm b/Master/xemtex/perl/site/lib/Tk/Wm.pm
new file mode 100644
index 00000000000..a148987f350
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Wm.pm
@@ -0,0 +1,165 @@
+# Copyright (c) 1995-1999 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 = '3.023'; # $Id: //depot/Tk8/Tk/Wm.pm#23 $
+
+use Tk::Submethods ( 'wm' => [qw(grid tracing)] );
+
+Direct Tk::Submethods ('wm' => [qw(aspect client colormapwindows command
+ deiconify focusmodel frame geometry group
+ iconbitmap iconify iconimage iconmask iconname
+ iconwindow maxsize minsize overrideredirect positionfrom
+ protocol resizable saveunder 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);
+ $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/xemtex/perl/site/lib/Tk/X.pm b/Master/xemtex/perl/site/lib/Tk/X.pm
new file mode 100644
index 00000000000..856673d4bbe
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/X.pm
@@ -0,0 +1,398 @@
+package Tk::X;
+
+use strict;
+use Carp;
+use vars qw($VERSION @EXPORT $AUTOLOAD);
+$VERSION = '3.016'; # $Id: //depot/Tk8/Xlib/X/X.pm#16 $
+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/xemtex/perl/site/lib/Tk/X11/license.terms b/Master/xemtex/perl/site/lib/Tk/X11/license.terms
new file mode 100644
index 00000000000..3dcd816f4a3
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/X11/license.terms
@@ -0,0 +1,32 @@
+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.
diff --git a/Master/xemtex/perl/site/lib/Tk/Xcamel.gif b/Master/xemtex/perl/site/lib/Tk/Xcamel.gif
new file mode 100644
index 00000000000..cb88bc0afd8
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/Xcamel.gif
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/act_folder.xbm b/Master/xemtex/perl/site/lib/Tk/act_folder.xbm
new file mode 100644
index 00000000000..fc82949945b
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/act_folder.xpm b/Master/xemtex/perl/site/lib/Tk/act_folder.xpm
new file mode 100644
index 00000000000..0e7d682713a
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/anim.gif b/Master/xemtex/perl/site/lib/Tk/anim.gif
new file mode 100644
index 00000000000..96a50b701be
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/anim.gif
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/balArrow.xbm b/Master/xemtex/perl/site/lib/Tk/balArrow.xbm
new file mode 100644
index 00000000000..ee0664a4727
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/cbxarrow.xbm b/Master/xemtex/perl/site/lib/Tk/cbxarrow.xbm
new file mode 100644
index 00000000000..ae4054488b9
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/file.xbm b/Master/xemtex/perl/site/lib/Tk/file.xbm
new file mode 100644
index 00000000000..7bf12bb4c9f
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/file.xpm b/Master/xemtex/perl/site/lib/Tk/file.xpm
new file mode 100644
index 00000000000..10cc24f9a1e
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/folder.xbm b/Master/xemtex/perl/site/lib/Tk/folder.xbm
new file mode 100644
index 00000000000..0398f0de777
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/folder.xpm b/Master/xemtex/perl/site/lib/Tk/folder.xpm
new file mode 100644
index 00000000000..fda7c15a549
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/icon.gif b/Master/xemtex/perl/site/lib/Tk/icon.gif
new file mode 100644
index 00000000000..dfe6b6621f2
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/icon.gif
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/license.terms b/Master/xemtex/perl/site/lib/Tk/license.terms
new file mode 100644
index 00000000000..6a5d3728366
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/openfile.xbm b/Master/xemtex/perl/site/lib/Tk/openfile.xbm
new file mode 100644
index 00000000000..859e2e57608
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/openfolder.xbm b/Master/xemtex/perl/site/lib/Tk/openfolder.xbm
new file mode 100644
index 00000000000..59ee624efd0
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/openfolder.xpm b/Master/xemtex/perl/site/lib/Tk/openfolder.xpm
new file mode 100644
index 00000000000..191fe1e72bc
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/prolog.ps b/Master/xemtex/perl/site/lib/Tk/prolog.ps
new file mode 100644
index 00000000000..409e06a65a0
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/srcfile.xpm b/Master/xemtex/perl/site/lib/Tk/srcfile.xpm
new file mode 100644
index 00000000000..06a40a96c84
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/textfile.xpm b/Master/xemtex/perl/site/lib/Tk/textfile.xpm
new file mode 100644
index 00000000000..8fa8d2f9032
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/tranicon.gif b/Master/xemtex/perl/site/lib/Tk/tranicon.gif
new file mode 100644
index 00000000000..dc7d494c572
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/tranicon.gif
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/widgets.pm b/Master/xemtex/perl/site/lib/Tk/widgets.pm
new file mode 100644
index 00000000000..742866216cc
--- /dev/null
+++ b/Master/xemtex/perl/site/lib/Tk/widgets.pm
@@ -0,0 +1,21 @@
+package Tk::widgets;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '3.011'; # $Id: //depot/Tk8/Tk/widgets.pm#11 $
+
+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/xemtex/perl/site/lib/Tk/win.xbm b/Master/xemtex/perl/site/lib/Tk/win.xbm
new file mode 100644
index 00000000000..13c05e8c2d7
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/winfolder.xpm b/Master/xemtex/perl/site/lib/Tk/winfolder.xpm
new file mode 100644
index 00000000000..73fe734c6d0
--- /dev/null
+++ b/Master/xemtex/perl/site/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/xemtex/perl/site/lib/Tk/wintext.xpm b/Master/xemtex/perl/site/lib/Tk/wintext.xpm
new file mode 100644
index 00000000000..50b2d5587dd
--- /dev/null
+++ b/Master/xemtex/perl/site/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. ",
+" ........... ",
+" "
+};