diff options
Diffstat (limited to 'Master/xemtex/perl/site/lib')
186 files changed, 21666 insertions, 0 deletions
diff --git a/Master/xemtex/perl/site/lib/Tk.pm b/Master/xemtex/perl/site/lib/Tk.pm new file mode 100644 index 00000000000..db05463d66d --- /dev/null +++ b/Master/xemtex/perl/site/lib/Tk.pm @@ -0,0 +1,696 @@ +# +# 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 + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in Tk/license.terms due to partial +# derivation from Tk8.0 sources. +# +package Tk; +require 5.00404; +use Tk::Event (); +use AutoLoader qw(AUTOLOAD); +use DynaLoader; +use base qw(Exporter DynaLoader); + +*fileevent = \&Tk::Event::IO::fileevent; + +BEGIN { + if($^O eq 'cygwin') + { + require Tk::Config; + $Tk::platform = $Tk::Config::win_arch; + $Tk::platform = 'unix' if $Tk::platform eq 'x'; + } + else + { + $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; + } +}; + +$Tk::tearoff = 1 if ($Tk::platform eq 'unix'); + +@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); +@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION + DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS + IDLE_EVENTS ALL_EVENTS + NORMAL_BG ACTIVE_BG SELECT_BG + SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); +%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], + variables => [qw(*widget *event)], + colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG + TROUGH INDICATOR DISABLED BLACK WHITE)], + ); + +use strict; + +use Carp; + +# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow +# is created, $VERSION is checked by bootstrap +$Tk::version = '8.0'; +$Tk::patchLevel = '8.0'; +$Tk::VERSION = '800.024'; +$Tk::XS_VERSION = $Tk::VERSION; +$Tk::strictMotif = 0; + +{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} +$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); + +$Tk::widget = undef; +$Tk::event = undef; + +use vars qw($inMainLoop); + +bootstrap Tk; + +my $boot_time = timeofday(); + +# This is a workround for Solaris X11 locale handling +Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) + if (NeedPreload() && -d '/usr/openwin/lib'); + +use Tk::Submethods ('option' => [qw(add get clear readfile)], + 'clipboard' => [qw(clear append)] + ); + +sub _backTrace +{ + my $w = shift; + my $i = 1; + my ($pack,$file,$line,$sub) = caller($i++); + while (1) + { + my $loc = "at $file line $line"; + ($pack,$file,$line,$sub) = caller($i++); + last unless defined($sub); + return 1 if $sub eq '(eval)'; + $w->AddErrorInfo("$sub $loc"); + } + return 0; +} + +sub BackTrace +{ + my $w = shift; + return unless (@_ || $@); + my $mess = (@_) ? shift : "$@"; + die "$mess\n" if $w->_backTrace; + # if we get here we are not in an eval so report now + $w->Fail($mess); + $w->idletasks; + die "$mess\n"; +} + +# +# This is a $SIG{__DIE__} handler which does not change the $@ +# string in the way 'croak' does, but rather add to Tk's ErrorInfo. +# It stops at 1st enclosing eval on assumption that the eval +# is part of Tk call process and will add its own context to ErrorInfo +# and then pass on the error. +# +sub __DIE__ +{ + my $mess = shift; + my $w = $Tk::widget; + # Note that if a __DIE__ handler returns it re-dies up the chain. + return unless defined $w; + return if $w->_backTrace; + # Not in an eval - should not happen +} + +sub XEvent::xy { shift->Info('xy') } + +sub XEvent::AUTOLOAD +{ + my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; + no strict 'refs'; + *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; + goto &$XEvent::AUTOLOAD; +} + +sub NoOp { } + +sub Ev +{ + my @args = @_; + my $obj; + if (@args == 1) + { + my $arg = pop(@args); + $obj = (ref $arg) ? $arg : \$arg; + } + else + { + $obj = \@args; + } + return bless $obj,'Tk::Ev'; +} + +sub InitClass +{ + my ($package,$parent) = @_; + croak "Unexpected type of parent $parent" unless(ref $parent); + croak "$parent is not a widget" unless($parent->IsWidget); + my $mw = $parent->MainWindow; + my $hash = $mw->TkHash('_ClassInit_'); + unless (exists $hash->{$package}) + { + $package->Install($mw); + $hash->{$package} = $package->ClassInit($mw); + } +} + +require Tk::Widget; +require Tk::Image; +require Tk::MainWindow; + +sub Exists +{my $w = shift; + return defined($w) && ref($w) && $w->IsWidget && $w->exists; +} + +sub Time_So_Far +{ + return timeofday() - $boot_time; +} + +# Selection* are not autoloaded as names are too long. + +sub SelectionOwn +{my $widget = shift; + selection('own',(@_,$widget)); +} + +sub SelectionOwner +{ + selection('own','-displayof',@_); +} + +sub SelectionClear +{ + selection('clear','-displayof',@_); +} + +sub SelectionExists +{ + selection('exists','-displayof',@_); +} + +sub SelectionHandle +{my $widget = shift; + my $command = pop; + selection('handle',@_,$widget,$command); +} + +sub SplitString +{ + local $_ = shift; + my (@arr, $tmp); + while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { + if (defined $1) { push @arr, $1 } + else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } + } + # carp '('.join(',',@arr).")"; + return @arr; +} + +sub Methods +{ + my ($package) = caller; + no strict 'refs'; + foreach my $meth (@_) + { + my $name = $meth; + *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; + } +} + + +sub MessageBox { + my ($kind,%args) = @_; + require Tk::Dialog; + my $parent = delete $args{'-parent'}; + my $args = \%args; + + $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; + $args->{-text} = delete $args->{-message} if defined $args->{-message}; + $args->{-type} = 'OK' unless defined $args->{-type}; + + my $type; + if (defined($type = delete $args->{-type})) { + delete $args->{-type}; + my @buttons = grep($_,map(ucfirst($_), + split(/(abort|retry|ignore|yes|no|cancel|ok)/, + lc($type)))); + $args->{-buttons} = [@buttons]; + $args->{-default_button} = delete $args->{-default} if + defined $args->{-default}; + if (not defined $args->{-default_button} and scalar(@buttons) == 1) { + $args->{-default_button} = $buttons[0]; + } + my $md = $parent->Dialog(%$args); + my $an = $md->Show; + $md->destroy; + return $an; + } +} # end messageBox + +sub messageBox +{ + my ($widget,%args) = @_; + $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; + tk_messageBox(-parent => $widget, %args); +} + +sub getOpenFile +{ + tk_getOpenFile(-parent => shift,@_); +} + +sub getSaveFile +{ + tk_getSaveFile(-parent => shift,@_); +} + +sub chooseColor +{ + tk_chooseColor(-parent => shift,@_); +} + +sub DialogWrapper +{ + my ($method,$kind,%args) = @_; + my $created = 0; + my $w = delete $args{'-parent'}; + if (defined $w) + { + $args{'-popover'} = $w; + } + else + { + $w = MainWindow->new; + $w->withdraw; + $created = 1; + } + my $mw = $w->MainWindow; + my $fs = $mw->{$kind}; + unless (defined $fs) + { + $mw->{$kind} = $fs = $mw->$method(%args); + } + else + { + $fs->configure(%args); + } + my $val = $fs->Show; + $w->destroy if $created; + return $val; +} + +sub ColorDialog +{ + require Tk::ColorEditor; + DialogWrapper('ColorDialog',@_); +} + +sub FDialog +{ + require Tk::FBox; + my $cmd = shift; + if ($cmd =~ /Save/) + { + push @_, -type => 'save'; + } + DialogWrapper('FBox', $cmd, @_); +} + +*MotifFDialog = \&FDialog; + +sub MainLoop +{ + unless ($inMainLoop) + { + local $inMainLoop = 1; + while (Tk::MainWindow->Count) + { + DoOneEvent(0); + } + } +} + +sub tkinit { return MainWindow->new(@_) } + +# a wrapper on eval which turns off user $SIG{__DIE__} +sub catch (&) +{ + my $sub = shift; + eval {local $SIG{'__DIE__'}; &$sub }; +} + +my $Home; + +sub TranslateFileName +{ + local $_ = shift; + unless (defined $Home) + { + $Home = $ENV{'HOME'} || ($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}); + $Home =~ s#\\#/#g; + $Home .= '/' unless $Home =~ m#/$#; + } + s#~/#$Home#g; + # warn $_; + return $_; +} + +sub findINC +{ + my $file = join('/',@_); + my $dir; + $file =~ s,::,/,g; + foreach $dir (@INC) + { + my $path; + return $path if (-e ($path = "$dir/$file")); + } + return undef; +} + +sub idletasks +{ + shift->update('idletasks'); +} + + +1; + +__END__ + +sub Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; +} + +sub CancelRepeat +{ + my $w = shift->MainWindow; + my $id = delete $w->{_afterId_}; + $w->after('cancel',$id) if (defined $id); +} + +sub RepeatId +{ + my ($w,$id) = @_; + $w = $w->MainWindow; + $w->CancelRepeat; + $w->{_afterId_} = $id; +} + + + +#---------------------------------------------------------------------------- +# focus.tcl -- +# +# This file defines several procedures for managing the input +# focus. +# +# @(#) focus.tcl 1.6 94/12/19 17:06:46 +# +# 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. + +sub FocusChildren { shift->children } + +# +# focusNext -- +# This procedure is invoked to move the input focus to the next window +# after a given one. "Next" is defined in terms of the window +# stacking order, with all the windows underneath a given top-level +# (no matter how deeply nested in the hierarchy) considered except +# for frames and toplevels. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the next window after this one in the traversal +# order. +sub focusNext +{ + my $w = shift; + my $cur = $w; + while (1) + { + # Descend to just before the first child of the current widget. + my $parent = $cur; + my @children = $cur->FocusChildren(); + my $i = -1; + # Look for the next sibling that isn't a top-level. + while (1) + { + $i += 1; + if ($i < @children) + { + $cur = $children[$i]; + next if ($cur->toplevel == $cur); + last + } + # No more siblings, so go to the current widget's parent. + # If it's a top-level, break out of the loop, otherwise + # look for its next sibling. + $cur = $parent; + last if ($cur->toplevel() == $cur); + $parent = $parent->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } +} +# focusPrev -- +# This procedure is invoked to move the input focus to the previous +# window before a given one. "Previous" is defined in terms of the +# window stacking order, with all the windows underneath a given +# top-level (no matter how deeply nested in the hierarchy) considered. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the previous window before this one in the traversal +# order. +sub focusPrev +{ + my $w = shift; + my $cur = $w; + my @children; + my $i; + my $parent; + while (1) + { + # Collect information about the current window's position + # among its siblings. Also, if the window is a top-level, + # then reposition to just after the last child of the window. + if ($cur->toplevel() == $cur) + { + $parent = $cur; + @children = $cur->FocusChildren(); + $i = @children; + } + else + { + $parent = $cur->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + # Go to the previous sibling, then descend to its last descendant + # (highest in stacking order. While doing this, ignore top-levels + # and their descendants. When we run out of descendants, go up + # one level to the parent. + while ($i > 0) + { + $i--; + $cur = $children[$i]; + next if ($cur->toplevel() == $cur); + $parent = $cur; + @children = $parent->FocusChildren(); + $i = @children; + } + $cur = $parent; + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } + +} + +sub FocusOK +{ + my $w = shift; + my $value; + catch { $value = $w->cget('-takefocus') }; + if (!$@ && defined($value)) + { + return 0 if ($value eq '0'); + return $w->viewable if ($value eq '1'); + $value = $w->$value(); + return $value if (defined $value); + } + if (!$w->viewable) + { + return 0; + } + catch { $value = $w->cget('-state') } ; + if (!$@ && defined($value) && $value eq 'disabled') + { + return 0; + } + $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); + return $value; +} + + +# focusFollowsMouse +# +# If this procedure is invoked, Tk will enter "focus-follows-mouse" +# mode, where the focus is always on whatever window contains the +# mouse. If this procedure isn't invoked, then the user typically +# has to click on a window to give it the focus. +# +# Arguments: +# None. + +sub EnterFocus +{ + my $w = shift; + my $Ev = $w->XEvent; + my $d = $Ev->d; + $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); +} + +sub tabFocus +{ + shift->Tk::focus; +} + +sub focusFollowsMouse +{ + my $widget = shift; + $widget->bind('all','<Enter>','EnterFocus'); +} + +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. +sub TraverseToMenu +{ + my $w = shift; + my $char = shift; + return unless(defined $char && $char ne ''); + $w = $w->toplevel->FindMenu($char); +} +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. +sub FirstMenu +{ + my $w = shift; + $w = $w->toplevel->FindMenu(''); +} + +# These wrappers don't use method syntax so need to live +# in same package as raw Tk routines are newXS'ed into. + +sub Selection +{my $widget = shift; + my $cmd = shift; + croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); + croak "Use Selection\u$cmd()"; +} + +# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) +# calls it when it does its eval "require $base" +#sub Clipboard +#{my $w = shift; +# my $cmd = shift; +# croak "Use clipboard\u$cmd()"; +#} + +sub Receive +{ + my $w = shift; + warn 'Receive(' . join(',',@_) .')'; + die 'Tk rejects send(' . join(',',@_) .")\n"; +} + +sub break +{ + die "_TK_BREAK_\n"; +} + +sub updateWidgets +{ + my ($w) = @_; + while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) + { + } + $w; +} + +sub ImageNames +{ + image('names'); +} + +sub ImageTypes +{ + image('types'); +} + +sub interps +{ + my $w = shift; + return $w->winfo('interps','-displayof'); +} + +sub lsearch +{my $ar = shift; + my $x = shift; + my $i; + for ($i = 0; $i < scalar @$ar; $i++) + { + return $i if ($$ar[$i] eq $x); + } + return -1; +} + + + + 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 Binary files differnew file mode 100644 index 00000000000..cb88bc0afd8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/Tk/Xcamel.gif 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 Binary files differnew file mode 100644 index 00000000000..96a50b701be --- /dev/null +++ b/Master/xemtex/perl/site/lib/Tk/anim.gif 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 Binary files differnew file mode 100644 index 00000000000..dfe6b6621f2 --- /dev/null +++ b/Master/xemtex/perl/site/lib/Tk/icon.gif 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 Binary files differnew file mode 100644 index 00000000000..dc7d494c572 --- /dev/null +++ b/Master/xemtex/perl/site/lib/Tk/tranicon.gif 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. ", +" ........... ", +" " +}; diff --git a/Master/xemtex/perl/site/lib/Win32/API.pm b/Master/xemtex/perl/site/lib/Win32/API.pm new file mode 100644 index 00000000000..154de7a80ee --- /dev/null +++ b/Master/xemtex/perl/site/lib/Win32/API.pm @@ -0,0 +1,719 @@ +package Win32::API; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API - Perl Win32 API Import Facility +# +# Version: 0.41 +# Date: 10 Mar 2003 +# Author: Aldo Calpini <dada@perl.it> +# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( $DEBUG ); +$DEBUG = 0; + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API::Type; +use Win32::API::Struct; + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = "0.41"; + +#### some package-global hash to +#### keep track of the imported +#### libraries and procedures +my %Libraries = (); +my %Procedures = (); + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $dll, $proc, $in, $out) = @_; + my $hdll; + my $self = {}; + + #### avoid loading a library more than once + if(exists($Libraries{$dll})) { + # print "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; + $hdll = $Libraries{$dll}; + } else { + # print "Win32::API::new: Loading library '$dll'\n"; + $hdll = Win32::API::LoadLibrary($dll); + $Libraries{$dll} = $hdll; + } + + #### if the dll can't be loaded, set $! to Win32's GetLastError() + if(!$hdll) { + $! = Win32::GetLastError(); + return undef; + } + + #### determine if we have a prototype or not + if( (not defined $in) and (not defined $out) ) { + ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc ); + return undef unless $proc; + $self->{proto} = 1; + } else { + $self->{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } + $self->{out} = type_to_num($out); + } + + #### first try to import the function of given name... + my $hproc = Win32::API::GetProcAddress($hdll, $proc); + + #### ...then try appending either A or W (for ASCII or Unicode) + if(!$hproc) { + my $tproc = $proc; + $tproc .= (IsUnicode() ? "W" : "A"); + # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; + $hproc = Win32::API::GetProcAddress($hdll, $tproc); + } + + #### ...if all that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + return undef; + } + + #### ok, let's stuff the object + $self->{procname} = $proc; + $self->{dll} = $hdll; + $self->{dllname} = $dll; + $self->{proc} = $hproc; + + #### keep track of the imported function + $Libraries{$dll} = $hdll; + $Procedures{$dll}++; + + #### cast the spell + bless($self, $class); + return $self; +} + +sub Import { + my($class, $dll, $proc, $in, $out) = @_; + $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0; + my $P = (caller)[0]; + eval qq( + sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); } + ); + return $@ ? 0 : 1; +} + + +####################################################################### +# PRIVATE METHODS +# +sub DESTROY { + my($self) = @_; + + #### decrease this library's procedures reference count + $Procedures{$self->{dllname}}--; + + #### once it reaches 0, free it + if($Procedures{$self->{dllname}} == 0) { + # print "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n"; + Win32::API::FreeLibrary($Libraries{$self->{dllname}}); + delete($Libraries{$self->{dllname}}); + } +} + +sub type_to_num { + my $type = shift; + my $out = shift; + my $num; + + if( $type eq 'N' + or $type eq 'n' + or $type eq 'l' + or $type eq 'L' + ) { + $num = 1; + } elsif($type eq 'P' + or $type eq 'p' + ) { + $num = 2; + } elsif($type eq 'I' + or $type eq 'i' + ) { + $num = 3; + } elsif($type eq 'f' + or $type eq 'F' + ) { + $num = 4; + } elsif($type eq 'D' + or $type eq 'd' + ) { + $num = 5; + } elsif($type eq 'c' + or $type eq 'C' + ) { + $num = 6; + } else { + $num = 0; + } + unless(defined $out) { + if( $type eq 's' + or $type eq 'S' + ) { + $num = 51; + } elsif($type eq 'b' + or $type eq 'B' + ) { + $num = 22; + } elsif($type eq 'k' + or $type eq 'K' + ) { + $num = 101; + } + } + return $num; +} + +sub parse_prototype { + my($proto) = @_; + + my @in_params = (); + my @in_types = (); + if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) { + my $ret = $1; + my $proc = $2; + my $params = $3; + + $params =~ s/^\s+//; + $params =~ s/\s+$//; + + DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc; + DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params; + + foreach my $param (split(/\s*,\s*/, $params)) { + my($type, $name); + if($param =~ /(\S+)\s+(\S+)/) { + ($type, $name) = ($1, $2); + } + + if(Win32::API::Type::is_known($type)) { + if(Win32::API::Type::is_pointer($type)) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num('P'); + push(@in_params, type_to_num('P')); + } else { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num( Win32::API::Type->packing( $type ) ); + push(@in_params, type_to_num( Win32::API::Type->packing( $type ) )); + } + } elsif( Win32::API::Struct::is_known( $type ) ) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, 'S', type_to_num('S'); + push(@in_params, type_to_num('S')); + } else { + warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; + push(@in_params, type_to_num('I')); + } + push(@in_types, $type); + + } + DEBUG "parse_prototype: IN=[ @in_params ]\n"; + + + + if(Win32::API::Type::is_known($ret)) { + if(Win32::API::Type::is_pointer($ret)) { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num('P'); + return ( $proc, \@in_params, \@in_types, type_to_num('P') ); + } else { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num( Win32::API::Type->packing( $ret ) ); + return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) ); + } + } else { + warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; + return ( $proc, \@in_params, \@in_types, type_to_num('I') ); + } + + } else { + warn "Win32::API::parse_prototype: bad prototype '$proto'"; + return undef; + } +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API - Perl Win32 API Import Facility + +=head1 SYNOPSIS + + #### Method 1: with prototype + + use Win32::API; + $function = Win32::API->new( + 'mydll, 'int sum_integers(int a, int b)', + ); + $return = $function->Call(3, 2); + + #### Method 2: with parameter list + + use Win32::API; + $function = Win32::API->new( + 'mydll', 'sum_integers', 'II', 'I', + ); + $return = $function->Call(3, 2); + + #### Method 3: with Import + + use Win32::API; + Win32::API->Import( + 'mydll', 'int sum_integers(int a, int b)', + ); + $return = sum_integers(3, 2); + + +=for LATER-UNIMPLEMENTED + #### or + use Win32::API mydll => 'int sum_integers(int a, int b)'; + $return = sum_integers(3, 2); + + +=head1 ABSTRACT + +With this module you can import and call arbitrary functions +from Win32's Dynamic Link Libraries (DLL), without having +to write an XS extension. Note, however, that this module +can't do anything (parameters input and output is limited +to simpler cases), and anyway a regular XS extension is +always safer and faster. + +The current version of Win32::API is available at my website: + + http://dada.perl.it/ + +It's also available on your nearest CPAN mirror (but allow a few days +for worldwide spreading of the latest version) reachable at: + + http://www.perl.com/CPAN/authors/Aldo_Calpini/ + +A short example of how you can use this module (it just gets the PID of +the current process, eg. same as Perl's internal C<$$>): + + use Win32::API; + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +The possibilities are nearly infinite (but not all are good :-). +Enjoy it. + + +=head1 CREDITS + +All the credits go to Andrea Frosini +for the neat assembler trick that makes this thing work. +I've also used some work by Dave Roth for the prototyping stuff. +A big thank you also to Gurusamy Sarathy for his +unvaluable help in XS development, and to all the Perl community for +being what it is. + + +=head1 DESCRIPTION + +To use this module put the following line at the beginning of your script: + + use Win32::API; + +You can now use the C<new()> function of the Win32::API module to create a +new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the +C<Call()> method on this object to perform a call to the imported API +(see L<CALLING AN IMPORTED FUNCTION>). + +Starting from version 0.40, you can also avoid creating a Win32::API object +and instead automatically define a Perl sub with the same name of the API +function you're importing. The details of the API definitions are the same, +just the call is different: + + my $GetCurrentProcessId = Win32::API->new( + "kernel32", "int GetCurrentProcessId()" + ); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Note that C<Import> returns 1 on success and 0 on failure (in which case you +can check the content of C<$^E>). + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file +with the C<new()> function. This will create a Perl object that contains the +reference to that function, which you can later C<Call()>. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The C prototype of the function. + +=back + +See L<Win32::API::Type> for a list of the known parameter types and +L<Win32::API::Struct> for information on how to define a structure. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass 4 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The name of the function (as exported by the library). + +=item 3. +The number and types of the arguments the function expects as input. + +=item 4. +The type of the value returned by the function. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C<GetTempPath()>. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B<Win32 SDK Reference>; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F<KERNEL32.DLL> +system file. +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +So, you don't have to write F<C:\windows\system\kernel32.dll>; +only F<kernel32> is enough: + + $GetTempPath = new Win32::API('kernel32', ... + +=item B<2.> + +Now for the second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B<Quick View> +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. +If their capitalization looks correct, then it's probably a 32 bit +DLL. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B<A> or B<W> to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B<A> to the name and try again; if the extension is built on a +Unicode system, then it will try with the B<W> instead. +So our function name will be: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... + +In our case C<GetTempPath> is really loaded as C<GetTempPathA>. + +=item B<3.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C<I>: +value is an integer (int) + +=item C<N>: +value is a number (long) + +=item C<F>: +value is a floating point number (float) + +=item C<D>: +value is a double precision number (double) + +=item C<C>: +value is a char (char) + +=item C<P>: +value is a pointer (to a string, structure, etc...) + +=item C<S>: +value is a Win32::API::Struct object (see below) + +=item C<K>: +value is a Win32::API::Callback object (see L<Win32::API::Callback>) + +=back + +Our function needs two parameters: a number (C<DWORD>) and a pointer to a +string (C<LPSTR>): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth and final parameter is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B<V> +(for C<void>), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C<DWORD>, so +our return type will be B<N>: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +C<defined>, otherwise either the function or the library could not be +loaded; in this case, C<$!> will be set to the error message reported +by Windows. +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $!\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C<croak> an error message and C<die>. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters, you can use either a constant expression +or a variable, while B<for pointers you must use a variable name> (no +Perl references, just a plain variable name). +Also note that B<memory must be allocated before calling the function>, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get C<Runtime exception> errors, and generally nothing will +work. The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you don't need to pass a reference to the variable +(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B<pointer to a structure>: as you can see, our structure is named +'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at +the beginning of the structure name when feeding it to a Win32::API +call. + +For more information, see also L<Win32::API::Struct>. + +If you don't want (or can't) use the Win32::API::Struct facility, +you can still use the low-level approach to use structures: + + +=over 4 + +=item 1. +you have to pack() the required elements in a variable: + + $lpPoint = pack('LL', 0, 0); # store two LONGs + +=item 2. to access the values stored in a structure, unpack() it as required: + + ($x, $y) = unpack('LL', $lpPoint); # get the actual values + +=back + + +The rest is left as an exercise to the reader... + + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=cut + + diff --git a/Master/xemtex/perl/site/lib/Win32/API/Struct.pm b/Master/xemtex/perl/site/lib/Win32/API/Struct.pm new file mode 100644 index 00000000000..acd160a95a8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/Win32/API/Struct.pm @@ -0,0 +1,528 @@ +package Win32::API::Struct; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Struct - Perl Win32 API struct Facility +# +# Version: 0.40 +# Date: 07 Mar 2003 +# Author: Aldo Calpini <dada@perl.it> +# $Id: Struct.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = "0.40"; + +use Win32::API::Type; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +my %Known = (); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +sub typedef { + my $class = shift; + my $struct = shift; + my($type, $name); + my $self = { + align => undef, + typedef => [], + }; + while(defined($type = shift)) { + $name = shift; + $name =~ s/;$//; + push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); + } + + $Known{$struct} = $self; + return 1; +} + + +sub recognize { + my($type, $name) = @_; + my($size, $packing); + if(exists $Known{$type}) { + $packing = ">"; + return $name, $packing, $type; + } else { + $packing = Win32::API::Type::packing($type); + return undef unless defined $packing; + if($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing."*".$size; + } + DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; + return $name, $packing, $type; + } +} + +sub new { + my $class = shift; + my($type, $name); + my $self = { + typedef => [], + }; + if($#_ == 0) { + if(exists $Known{$_[0]}) { + DEBUG "(PM)Struct::new: got '$_[0]'\n"; + $self->{typedef} = $Known{$_[0]}->{typedef}; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if($packing eq '>') { + $self->{$name} = Win32::API::Struct->new($type); + } + } + $self->{__typedef__} = $_[0]; + } else { + carp "Unknown Win32::API::Struct '$_[0]'"; + return undef; + } + } else { + while(defined($type = shift)) { + $name = shift; + # print "new: found member $name ($type)\n"; + if(not exists $Win32::API::Type::Known{$type}) { + warn "Unknown Win32::API::Struct type '$type'"; + return undef; + } else { + push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); + } + } + } + return bless $self; +} + +sub members { + my $self = shift; + return map {$_->[0]} @{ $self->{typedef} }; +} + +sub sizeof { + my $self = shift; + my $size = 0; + my $align = 0; + my $first = undef; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + $size += $self->{$name}->sizeof(); + # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; + } else { + if($packing =~ /\w\*(\d+)/) { + $size += Win32::API::Type::sizeof($type) * $1; + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } else { + $size += Win32::API::Type::sizeof($type); + $first = Win32::API::Type::sizeof($type) unless defined $first; + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } + } + } + DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; + #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; + #return $first + (scalar(@{ $self->{typedef} })-1) * $align; + DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; + if(defined $align and $align > 0) { + return scalar(@{ $self->{typedef} }) * $align; + } else { + return $size; + } + return $size; +} + +sub align { + my $self = shift; + my $align = shift; + + if(not defined $align) { + return $self->{align} unless $self->{align} eq 'auto'; + $align = 0; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + #### ???? + } else { + if($packing =~ /\w\*(\d+)/) { + #### ???? + } else { + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + } + } + } + return $align; + } else { + $self->{align} = $align; + + } +} + +sub getPack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my @recipients = (); + + my $align = $self->align(); + + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; + + $packing .= $subpacking; + push(@items, @$subitems); + push(@recipients, @$subrecipients); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "a$size"; + } + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; + + if($type eq 'p') { + $type = "L"; + push(@items, Win32::API::PointerTo($self->{$name})); + } else { + push(@items, $self->{$name}); + } + $packing .= $type; + + if($Win32::API::Type::PackSize{$type} < $align) { + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@recipients, $self); + } + } + DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; + return($packing, [@items], [@recipients]); +} + + +sub Pack { + my $self = shift; + my($packing, $items, $recipients) = $self->getPack(); + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; + $self->{buffer} = pack($packing, @$items); + if(DEBUG) { + for my $i (0..$self->sizeof-1) { + printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + } + } + $self->{buffer_recipients} = $recipients +} + +sub getUnpack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my $align = $self->align(); + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, @subitems) = $self->{$name}->getUnpack(); + + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; + $packing .= $subpacking; + + + push(@items, @subitems); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "Z$size"; + } + + #if($type eq 'p') { + # $packing .= 'Z*'; + # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; + #} else { + $packing .= $type; + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; + #} + if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { + DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", + $type, $Win32::API::Type::PackSize{$type}, $align + ; + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@items, $name); + } + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; + return($packing, @items); +} + +sub Unpack { + my $self = shift; + my($packing, @items) = $self->getUnpack(); + my @itemvalue = unpack($packing, $self->{buffer}); + DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; + foreach my $i (0..$#items) { + my $recipient = $self->{buffer_recipients}->[$i]; + DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", + $recipient->{__typedef__}, + $items[$i], + $itemvalue[$i], + $itemvalue[$i], + ; + $recipient->{$items[$i]} = $itemvalue[$i]; + DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; + } +} + +sub FromMemory { + my($self, $addr) = @_; + DEBUG "(PM)Struct::FromMemory: doing Pack\n"; + $self->Pack(); + DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; + $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); + $self->Unpack(); + DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; + DEBUG "(PM)Struct::FromMemory: structure is now:\n"; + $self->Dump() if DEBUG; + DEBUG "\n"; +} + +sub Dump { + my $self = shift; + my $prefix = shift; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if( ref($self->{$name}) ) { + $self->{$name}->Dump($name); + } else { + printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; + } + } +} + + +sub is_known { + my $name = shift; + if(exists $Known{ $name }) { + return 1; + } else { + if($name =~ s/^LP//) { + return exists $Known{ $name }; + } + return 0; + } +} + +sub TIEHASH { + return Win32::API::Struct::new(@_); +} + +sub EXISTS { + +} + +sub FETCH { + my $self = shift; + my $key = shift; + + if($key eq 'sizeof') { + return $self->sizeof; + } + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + return $self->{$key}; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub STORE { + my $self = shift; + my($key, $val) = @_; + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + $self->{$key} = $val; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub FIRSTKEY { + my $self = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + return $members[0]; +} + +sub NEXTKEY { + my $self = shift; + my $key = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + for my $i (0..$#members-1) { + return $members[$i+1] if $members[$i] eq $key; + } + return undef; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Struct - C struct support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Struct->typedef( 'POINT', qw( + LONG x; + LONG y; + )); + + my $Point = Win32::API::Struct->new( 'POINT' ); + $Point->{x} = 1024; + $Point->{y} = 768; + + #### alternatively + + tie %Point, 'Win32::API::Struct', 'POINT'; + $Point{x} = 1024; + $Point{y} = 768; + + +=head1 ABSTRACT + +This module enables you to define C structs for use with +Win32::API. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. The main methods are C<typedef> and +C<new>, which are documented below. + +=over 4 + +=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> + +This method defines a structure named C<NAME>. The definition consists +of types and member names, just like in C. In fact, most of the +times you can cut the C definition for a structure and paste it +verbatim to your script, enclosing it in a C<qw()> block. The +function takes care of removing the semicolon after the member +name. + +The synopsis example could be written like this: + + Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); + +But it could also be written like this (note the indirect object +syntax), which is pretty cool: + + typedef Win32::API::Struct POINT => qw{ + LONG x; + LONG y; + }; + +Also note that C<typedef> automatically defines an 'LPNAME' type, +which holds a pointer to your structure. In the example above, +'LPPOINT' is also defined and can be used in a call to a +Win32::API (in fact, this is what you're really going to use when +doing API calls). + +=item C<new NAME> + +This creates a structure (a Win32::API::Struct object) of the +type C<NAME> (it must have been defined with C<typedef>). In Perl, +when you create a structure, all the members are undefined. But +when you use that structure in C (eg. a Win32::API call), you +can safely assume that they will be treated as zero (or NULL). + +=item C<sizeof> + +This returns the size, in bytes, of the structure. Acts just like +the C function of the same name. It is particularly useful for +structures that need a member to be initialized to the structure's +own size. + +=item C<align [SIZE]> + +Sets or returns the structure alignment (eg. how the structure is +stored in memory). This is a very advanced option, and you normally +don't need to mess with it. +All structures in the Win32 Platform SDK should work without it. +But if you define your own structure, you may need to give it an +explicit alignment. In most cases, passing a C<SIZE> of 'auto' +should keep the world happy. + +=back + +=head2 THE C<tie> INTERFACE + +Instead of creating an object with the C<new> method, you can +tie a hash, which will hold the desired structure, using the +C<tie> builtin function: + + tie %structure, Win32::API::Struct => 'NAME'; + +The differences between the tied and non-tied approaches are: + +=over 4 + +=item * +with tied structures, you can access members directly as +hash lookups, eg. + + # tied # non-tied + $Point{x} vs. $Point->{x} + +=item * +with tied structures, when you try to fetch or store a +member that is not part of the structure, it will result +in a warning, eg. + + print $Point{z}; + # this will warn: 'z' is not a member of Win32::API::Struct POINT + +=item * +when you pass a tied structure as a Win32::API parameter, +remember to backslash it, eg. + + # tied # non-tied + GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=cut diff --git a/Master/xemtex/perl/site/lib/Win32/API/Type.pm b/Master/xemtex/perl/site/lib/Win32/API/Type.pm new file mode 100644 index 00000000000..9ebe9ff57dc --- /dev/null +++ b/Master/xemtex/perl/site/lib/Win32/API/Type.pm @@ -0,0 +1,440 @@ +package Win32::API::Type; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Type - Perl Win32 API type definitions +# +# Version: 0.40 +# Date: 07 Mar 2003 +# Author: Aldo Calpini <dada@perl.it> +# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = "0.40"; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( %Known %PackSize %Modifier %Pointer ); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); + +INIT { + my $section = 'nothing'; + foreach (<DATA>) { + next if /^\s*#/ or /^\s*$/; + chomp; + if( /\[(.+)\]/) { + $section = $1; + next; + } + if($section eq 'TYPE') { + my($name, $packing) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + $Known{$name} = $packing; + } elsif($section eq 'PACKSIZE') { + my($packing, $size) = split(/\s+/); + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + $PackSize{$packing} = $size; + } elsif($section eq 'MODIFIER') { + my($modifier, $mapto) = split(/\s+/, $_, 2); + my %maps = (); + foreach my $item (split(/\s+/, $mapto)) { + my($k, $v) = split(/=/, $item); + $maps{$k} = $v; + } + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; + $Modifier{$modifier} = { %maps }; + } elsif($section eq 'POINTER') { + my($pointer, $pointto) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; + $Pointer{$pointer} = $pointto; + } + } +} + +sub new { + my $class = shift; + my($type) = @_; + my $packing = packing($type); + my $size = sizeof($type); + my $self = { + type => $type, + packing => $packing, + size => $size, + }; + return bless $self; +} + +sub typedef { + my $class = shift; + my($name, $type) = @_; + my $packing = packing($type, $name); + DEBUG "(PM)Type::typedef: packing='$packing'\n"; + my $size = sizeof($type); + $Known{$name} = $packing; + return 1; +} + + +sub is_known { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + return defined packing($type); + } +} + +sub sizeof { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return $self->{size}; + } else { + my $packing = packing($type); + if($packing =~ /(\w)\*(\d+)/) { + return $PackSize{ $1 } * $2; + } else { + return $PackSize{ $packing }; + } + } +} + +sub packing { + # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; + my $self = shift; + my $is_pointer = 0; + if(ref($self) =~ /Win32::API::Type/) { + # DEBUG "(PM)Type::packing: got an object\n"; + return $self->{packing}; + } + my $type = ($self eq 'Win32::API::Type') ? shift : $self; + my $name = shift; + + # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; + my($modifier, $size, $packing); + if(exists $Pointer{$type}) { + # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; + $type = $Pointer{$type}; + $is_pointer = 1; + } elsif($type =~ /(\w+)\s+(\w+)/) { + $modifier = $1; + $type = $2; + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; + } + + $type =~ s/\*$//; + + if(exists $Known{$type}) { + if(defined $name and $name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $Known{$type}[0]."*".$size; + # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; + } else { + $packing = $Known{$type}; + if($is_pointer and $packing eq 'c') { + $packing = "p"; + } + # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; + } + if(defined $modifier and exists $Modifier{$modifier}->{$type}) { + # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; + $packing = $Modifier{$modifier}->{$type}; + } + return $packing; + } else { + # DEBUG "(PM)Type::packing: NOT FOUND\n"; + return undef; + } +} + + +sub is_pointer { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + if($type =~ /\*$/) { + return 1; + } else { + return exists $Pointer{$type}; + } + } +} + +sub Pack { + my $type = $_[0]; + + if(packing($type) eq 'c' and is_pointer($type)) { + $_[1] = pack("Z*", $_[1]); + return $_[1]; + } + $_[1] = pack( packing($type), $_[1]); + return $_[1]; +} + +sub Unpack { + my $type = $_[0]; + if(packing($type) eq 'c' and is_pointer($type)) { + DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n"; + $_[1] = unpack("Z*", $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; + } + DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n"; + $_[1] = unpack( packing($type), $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Type - C type support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Type->typedef( 'my_number', 'LONG' ); + + +=head1 ABSTRACT + +This module is a support package for Win32::API that implements +C types for the import with prototype functionality. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. These are the methods of this package: + +=over 4 + +=item C<typedef NAME, TYPE> + +This method defines a new type named C<NAME>. This actually just +creates an alias for the already-defined type C<TYPE>, which you +can use as a parameter in a Win32::API call. + +=item C<sizeof TYPE> + +This returns the size, in bytes, of C<TYPE>. Acts just like +the C function of the same name. + +=item C<is_known TYPE> + +Returns true if C<TYPE> is known by Win32::API::Type, false +otherwise. + +=back + +=head2 SUPPORTED TYPES + +This module should recognize all the types defined in the +Win32 Platform SDK header files. +Please see the source for this module, in the C<__DATA__> section, +for the full list. + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=cut + + +__DATA__ + +[TYPE] +ATOM s +BOOL L +BOOLEAN c +BYTE C +CHAR c +COLORREF L +DWORD L +DWORD32 L +DWORD64 Q +FLOAT f +HACCEL L +HANDLE L +HBITMAP L +HBRUSH L +HCOLORSPACE L +HCONV L +HCONVLIST L +HCURSOR L +HDC L +HDDEDATA L +HDESK L +HDROP L +HDWP L +HENHMETAFILE L +HFILE L +HFONT L +HGDIOBJ L +HGLOBAL L +HHOOK L +HICON L +HIMC L +HINSTANCE L +HKEY L +HKL L +HLOCAL L +HMENU L +HMETAFILE L +HMODULE L +HPALETTE L +HPEN L +HRGN L +HRSRC L +HSZ L +HWINSTA L +HWND L +INT i +INT32 i +INT64 q +LANGID s +LCID L +LCSCSTYPE L +LCSGAMUTMATCH L +LCTYPE L +LONG l +LONG32 l +LONG64 q +LONGLONG q +LPARAM L +LRESULT L +REGSAM L +SC_HANDLE L +SC_LOCK L +SERVICE_STATUS_HANDLE L +SHORT s +SIZE_T L +SSIZE_T L +TBYTE c +TCHAR C +UCHAR C +UINT I +UINT_PTR L +UINT32 I +UINT64 Q +ULONG L +ULONG32 L +ULONG64 Q +ULONGLONG Q +USHORT S +WCHAR S +WORD S +WPARAM L +VOID c + +int i +long l +float f +double d +char c + +#CRITICAL_SECTION 24 -- a structure +#LUID ? 8 -- a structure +#VOID 0 +#CONST 4 +#FILE_SEGMENT_ELEMENT 8 -- a structure + +[PACKSIZE] +c 1 +C 1 +d 8 +f 4 +i 4 +I 4 +l 4 +L 4 +q 8 +Q 8 +s 2 +S 2 +p 4 + +[MODIFIER] +unsigned int=I long=L short=S char=C + +[POINTER] +INT_PTR INT +LPBOOL BOOL +LPBYTE BYTE +LPCOLORREF COLORREF +LPCSTR CHAR +#LPCTSTR CHAR or WCHAR +LPCTSTR CHAR +LPCVOID any +LPCWSTR WCHAR +LPDWORD DWORD +LPHANDLE HANDLE +LPINT INT +LPLONG LONG +LPSTR CHAR +#LPTSTR CHAR or WCHAR +LPTSTR CHAR +LPVOID VOID +LPWORD WORD +LPWSTR WCHAR + +PBOOL BOOL +PBOOLEAN BOOL +PBYTE BYTE +PCHAR CHAR +PCSTR CSTR +PCWCH CWCH +PCWSTR CWSTR +PDWORD DWORD +PFLOAT FLOAT +PHANDLE HANDLE +PHKEY HKEY +PINT INT +PLCID LCID +PLONG LONG +PSHORT SHORT +PSTR CHAR +#PTBYTE TBYTE -- +#PTCHAR TCHAR -- +#PTSTR CHAR or WCHAR +PTSTR CHAR +PUCHAR UCHAR +PUINT UINT +PULONG ULONG +PUSHORT USHORT +PVOID VOID +PWCHAR WCHAR +PWORD WORD +PWSTR WCHAR diff --git a/Master/xemtex/perl/site/lib/XML/Parser.pm b/Master/xemtex/perl/site/lib/XML/Parser.pm new file mode 100644 index 00000000000..f150b615a2d --- /dev/null +++ b/Master/xemtex/perl/site/lib/XML/Parser.pm @@ -0,0 +1,1089 @@ +# XML::Parser +# +# Copyright (c) 1998-2000 Larry Wall and Clark Cooper +# All rights reserved. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package XML::Parser; + +use Carp; +use IO::File; + +BEGIN { + require XML::Parser::Expat; + $VERSION = '2.31'; + die "Parser.pm and Expat.pm versions don't match" + unless $VERSION eq $XML::Parser::Expat::VERSION; +} + +use strict; + +use vars qw($VERSION %Built_In_Styles $LWP_load_failed); + +$LWP_load_failed = 0; + +sub new { + my ($class, %args) = @_; + my $style = $args{Style}; + + my $nonexopt = $args{Non_Expat_Options} ||= {}; + + $nonexopt->{Style} = 1; + $nonexopt->{Non_Expat_Options} = 1; + $nonexopt->{Handlers} = 1; + $nonexopt->{_HNDL_TYPES} = 1; + $nonexopt->{NoLWP} = 1; + + $args{NoLWP} = 1; + + $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters}; + $args{_HNDL_TYPES}->{Init} = 1; + $args{_HNDL_TYPES}->{Final} = 1; + + $args{Handlers} ||= {}; + my $handlers = $args{Handlers}; + + if (defined($style)) { + my $stylepkg = $style; + + if ($stylepkg !~ /::/) { + $stylepkg = "\u$style"; + + # I'm using the Built_In_Styles hash to define + # valid internal styles, since a style doesn't + # need to define any particular Handler to be valid. + # So I can't check for the existence of a particular sub. + + croak "Undefined style: $style" + unless defined($Built_In_Styles{$stylepkg}); + $stylepkg = 'XML::Parser::' . $stylepkg; + } + + my $htype; + foreach $htype (keys %{$args{_HNDL_TYPES}}) { + # Handlers explicity given override + # handlers from the Style package + unless (defined($handlers->{$htype})) { + + # A handler in the style package must either have + # exactly the right case as the type name or a + # completely lower case version of it. + + my $hname = "${stylepkg}::$htype"; + if (defined(&$hname)) { + $handlers->{$htype} = \&$hname; + next; + } + + $hname = "${stylepkg}::\L$htype"; + if (defined(&$hname)) { + $handlers->{$htype} = \&$hname; + next; + } + } + } + } + + unless (defined($handlers->{ExternEnt}) + or defined ($handlers->{ExternEntFin})) { + + if ($args{NoLWP} or $LWP_load_failed) { + $handlers->{ExternEnt} = \&file_ext_ent_handler; + $handlers->{ExternEntFin} = \&file_ext_ent_cleanup; + } + else { + # The following just bootstraps the real LWP external entity + # handler + + $handlers->{ExternEnt} = \&initial_ext_ent_handler; + + # No cleanup function available until LWPExternEnt.pl loaded + } + } + + $args{Pkg} ||= caller; + bless \%args, $class; +} # End of new + +sub setHandlers { + my ($self, @handler_pairs) = @_; + + croak("Uneven number of arguments to setHandlers method") + if (int(@handler_pairs) & 1); + + my @ret; + while (@handler_pairs) { + my $type = shift @handler_pairs; + my $handler = shift @handler_pairs; + unless (defined($self->{_HNDL_TYPES}->{$type})) { + my @types = sort keys %{$self->{_HNDL_TYPES}}; + + croak("Unknown Parser handler type: $type\n Valid types: @types"); + } + push(@ret, $type, $self->{Handlers}->{$type}); + $self->{Handlers}->{$type} = $handler; + } + + return @ret; +} # End of setHandlers + +sub parse_start { + my $self = shift; + my @expat_options = (); + + my ($key, $val); + while (($key, $val) = each %{$self}) { + push (@expat_options, $key, $val) + unless exists $self->{Non_Expat_Options}->{$key}; + } + + my %handlers = %{$self->{Handlers}}; + my $init = delete $handlers{Init}; + my $final = delete $handlers{Final}; + + my $expatnb = new XML::Parser::ExpatNB(@expat_options, @_); + $expatnb->setHandlers(%handlers); + + &$init($expatnb) + if defined($init); + + $expatnb->{_State_} = 1; + + $expatnb->{FinalHandler} = $final + if defined($final); + + return $expatnb; +} + +sub parse { + my $self = shift; + my $arg = shift; + my @expat_options = (); + my ($key, $val); + while (($key, $val) = each %{$self}) { + push(@expat_options, $key, $val) + unless exists $self->{Non_Expat_Options}->{$key}; + } + + my $expat = new XML::Parser::Expat(@expat_options, @_); + my %handlers = %{$self->{Handlers}}; + my $init = delete $handlers{Init}; + my $final = delete $handlers{Final}; + + $expat->setHandlers(%handlers); + + if ($self->{Base}) { + $expat->base($self->{Base}); + } + + &$init($expat) + if defined($init); + + my @result = (); + my $result; + eval { + $result = $expat->parse($arg); + }; + my $err = $@; + if ($err) { + $expat->release; + die $err; + } + + if ($result and defined($final)) { + if (wantarray) { + @result = &$final($expat); + } + else { + $result = &$final($expat); + } + } + + $expat->release; + + return unless defined wantarray; + return wantarray ? @result : $result; +} # End of parse + +sub parsestring { + my $self = shift; + $self->parse(@_); +} # End of parsestring + +sub parsefile { + my $self = shift; + my $file = shift; + local(*FILE); + open(FILE, $file) or croak "Couldn't open $file:\n$!"; + binmode(FILE); + my @ret; + my $ret; + + $self->{Base} = $file; + + if (wantarray) { + eval { + @ret = $self->parse(*FILE, @_); + }; + } + else { + eval { + $ret = $self->parse(*FILE, @_); + }; + } + my $err = $@; + close(FILE); + die $err if $err; + + return unless defined wantarray; + return wantarray ? @ret : $ret; +} # End of parsefile + + +sub initial_ext_ent_handler { + # This just bootstraps in the real lwp_ext_ent_handler which + # also loads the URI and LWP modules. + + unless ($LWP_load_failed) { + local($^W) = 0; + + my $stat = + eval { + require('XML/Parser/LWPExternEnt.pl'); + }; + + if ($stat) { + $_[0]->setHandlers(ExternEnt => \&lwp_ext_ent_handler, + ExternEntFin => \&lwp_ext_ent_cleanup); + + goto &lwp_ext_ent_handler; + } + + # Failed to load lwp handler, act as if NoLWP + + $LWP_load_failed = 1; + + my $cmsg = "Couldn't load LWP based external entity handler\n"; + $cmsg .= "Switching to file-based external entity handler\n"; + $cmsg .= " (To avoid this message, use NoLWP option to XML::Parser)\n"; + warn($cmsg); + } + + $_[0]->setHandlers(ExternEnt => \&file_ext_ent_handler, + ExternEntFin => \&file_ext_ent_cleanup); + goto &file_ext_ent_handler; + +} # End initial_ext_ent_handler + +sub file_ext_ent_handler { + my ($xp, $base, $path) = @_; + + # Prepend base only for relative paths + + if (defined($base) + and not ($path =~ m!^(?:[\\/]|\w+:)!)) + { + my $newpath = $base; + $newpath =~ s![^\\/:]*$!$path!; + $path = $newpath; + } + + if ($path =~ /^\s*[|>+]/ + or $path =~ /\|\s*$/) { + $xp->{ErrorMessage} + .= "System ID ($path) contains Perl IO control characters"; + return undef; + } + + my $fh = new IO::File($path); + unless (defined $fh) { + $xp->{ErrorMessage} + .= "Failed to open $path:\n$!"; + return undef; + } + + $xp->{_BaseStack} ||= []; + $xp->{_FhStack} ||= []; + + push(@{$xp->{_BaseStack}}, $base); + push(@{$xp->{_FhStack}}, $fh); + + $xp->base($path); + + return $fh; +} # End file_ext_ent_handler + +sub file_ext_ent_cleanup { + my ($xp) = @_; + + my $fh = pop(@{$xp->{_FhStack}}); + $fh->close; + + my $base = pop(@{$xp->{_BaseStack}}); + $xp->base($base); +} # End file_ext_ent_cleanup + +################################################################### + +package XML::Parser::Debug; +$XML::Parser::Built_In_Styles{Debug} = 1; + +sub Start { + my $expat = shift; + my $tag = shift; + print STDERR "@{$expat->{Context}} \\\\ (@_)\n"; +} + +sub End { + my $expat = shift; + my $tag = shift; + print STDERR "@{$expat->{Context}} //\n"; +} + +sub Char { + my $expat = shift; + my $text = shift; + $text =~ s/([\x80-\xff])/sprintf "#x%X;", ord $1/eg; + $text =~ s/([\t\n])/sprintf "#%d;", ord $1/eg; + print STDERR "@{$expat->{Context}} || $text\n"; +} + +sub Proc { + my $expat = shift; + my $target = shift; + my $text = shift; + my @foo = @{$expat->{Context}}; + print STDERR "@foo $target($text)\n"; +} + +################################################################### + +package XML::Parser::Subs; +$XML::Parser::Built_In_Styles{Subs} = 1; + +sub Start { + no strict 'refs'; + my $expat = shift; + my $tag = shift; + my $sub = $expat->{Pkg} . "::$tag"; + eval { &$sub($expat, $tag, @_) }; +} + +sub End { + no strict 'refs'; + my $expat = shift; + my $tag = shift; + my $sub = $expat->{Pkg} . "::${tag}_"; + eval { &$sub($expat, $tag) }; +} + +################################################################### + +package XML::Parser::Tree; +$XML::Parser::Built_In_Styles{Tree} = 1; + +sub Init { + my $expat = shift; + $expat->{Lists} = []; + $expat->{Curlist} = $expat->{Tree} = []; +} + +sub Start { + my $expat = shift; + my $tag = shift; + my $newlist = [ { @_ } ]; + push @{ $expat->{Lists} }, $expat->{Curlist}; + push @{ $expat->{Curlist} }, $tag => $newlist; + $expat->{Curlist} = $newlist; +} + +sub End { + my $expat = shift; + my $tag = shift; + $expat->{Curlist} = pop @{ $expat->{Lists} }; +} + +sub Char { + my $expat = shift; + my $text = shift; + my $clist = $expat->{Curlist}; + my $pos = $#$clist; + + if ($pos > 0 and $clist->[$pos - 1] eq '0') { + $clist->[$pos] .= $text; + } else { + push @$clist, 0 => $text; + } +} + +sub Final { + my $expat = shift; + delete $expat->{Curlist}; + delete $expat->{Lists}; + $expat->{Tree}; +} + +################################################################### + +package XML::Parser::Objects; +$XML::Parser::Built_In_Styles{Objects} = 1; + +sub Init { + my $expat = shift; + $expat->{Lists} = []; + $expat->{Curlist} = $expat->{Tree} = []; +} + +sub Start { + my $expat = shift; + my $tag = shift; + my $newlist = [ ]; + my $class = "${$expat}{Pkg}::$tag"; + my $newobj = bless { @_, Kids => $newlist }, $class; + push @{ $expat->{Lists} }, $expat->{Curlist}; + push @{ $expat->{Curlist} }, $newobj; + $expat->{Curlist} = $newlist; +} + +sub End { + my $expat = shift; + my $tag = shift; + $expat->{Curlist} = pop @{ $expat->{Lists} }; +} + +sub Char { + my $expat = shift; + my $text = shift; + my $class = "${$expat}{Pkg}::Characters"; + my $clist = $expat->{Curlist}; + my $pos = $#$clist; + + if ($pos >= 0 and ref($clist->[$pos]) eq $class) { + $clist->[$pos]->{Text} .= $text; + } else { + push @$clist, bless { Text => $text }, $class; + } +} + +sub Final { + my $expat = shift; + delete $expat->{Curlist}; + delete $expat->{Lists}; + $expat->{Tree}; +} + +################################################################ + +package XML::Parser::Stream; +$XML::Parser::Built_In_Styles{Stream} = 1; + +# This style invented by Tim Bray <tbray@textuality.com> + +sub Init { + no strict 'refs'; + my $expat = shift; + $expat->{Text} = ''; + my $sub = $expat->{Pkg} ."::StartDocument"; + &$sub($expat) + if defined(&$sub); +} + +sub Start { + no strict 'refs'; + my $expat = shift; + my $type = shift; + + doText($expat); + $_ = "<$type"; + + %_ = @_; + while (@_) { + $_ .= ' ' . shift() . '="' . shift() . '"'; + } + $_ .= '>'; + + my $sub = $expat->{Pkg} . "::StartTag"; + if (defined(&$sub)) { + &$sub($expat, $type); + } else { + print; + } +} + +sub End { + no strict 'refs'; + my $expat = shift; + my $type = shift; + + # Set right context for Text handler + push(@{$expat->{Context}}, $type); + doText($expat); + pop(@{$expat->{Context}}); + + $_ = "</$type>"; + + my $sub = $expat->{Pkg} . "::EndTag"; + if (defined(&$sub)) { + &$sub($expat, $type); + } else { + print; + } +} + +sub Char { + my $expat = shift; + $expat->{Text} .= shift; +} + +sub Proc { + no strict 'refs'; + my $expat = shift; + my $target = shift; + my $text = shift; + + doText($expat); + + $_ = "<?$target $text?>"; + + my $sub = $expat->{Pkg} . "::PI"; + if (defined(&$sub)) { + &$sub($expat, $target, $text); + } else { + print; + } +} + +sub Final { + no strict 'refs'; + my $expat = shift; + my $sub = $expat->{Pkg} . "::EndDocument"; + &$sub($expat) + if defined(&$sub); +} + +sub doText { + no strict 'refs'; + my $expat = shift; + $_ = $expat->{Text}; + + if (length($_)) { + my $sub = $expat->{Pkg} . "::Text"; + if (defined(&$sub)) { + &$sub($expat); + } else { + print; + } + + $expat->{Text} = ''; + } +} + +1; + +__END__ + +=head1 NAME + +XML::Parser - A perl module for parsing XML documents + +=head1 SYNOPSIS + + use XML::Parser; + + $p1 = new XML::Parser(Style => 'Debug'); + $p1->parsefile('REC-xml-19980210.xml'); + $p1->parse('<foo id="me">Hello World</foo>'); + + # Alternative + $p2 = new XML::Parser(Handlers => {Start => \&handle_start, + End => \&handle_end, + Char => \&handle_char}); + $p2->parse($socket); + + # Another alternative + $p3 = new XML::Parser(ErrorContext => 2); + + $p3->setHandlers(Char => \&text, + Default => \&other); + + open(FOO, 'xmlgenerator |'); + $p3->parse(*FOO, ProtocolEncoding => 'ISO-8859-1'); + close(FOO); + + $p3->parsefile('junk.xml', ErrorContext => 3); + +=begin man +.ds PI PI + +=end man + +=head1 DESCRIPTION + +This module provides ways to parse XML documents. It is built on top of +L<XML::Parser::Expat>, which is a lower level interface to James Clark's +expat library. Each call to one of the parsing methods creates a new +instance of XML::Parser::Expat which is then used to parse the document. +Expat options may be provided when the XML::Parser object is created. +These options are then passed on to the Expat object on each parse call. +They can also be given as extra arguments to the parse methods, in which +case they override options given at XML::Parser creation time. + +The behavior of the parser is controlled either by C<L</Style>> and/or +C<L</Handlers>> options, or by L</setHandlers> method. These all provide +mechanisms for XML::Parser to set the handlers needed by XML::Parser::Expat. +If neither C<Style> nor C<Handlers> are specified, then parsing just +checks the document for being well-formed. + +When underlying handlers get called, they receive as their first parameter +the I<Expat> object, not the Parser object. + +=head1 METHODS + +=over 4 + +=item new + +This is a class method, the constructor for XML::Parser. Options are passed +as keyword value pairs. Recognized options are: + +=over 4 + +=item * Style + +This option provides an easy way to create a given style of parser. The +built in styles are: L<"Debug">, L<"Subs">, L<"Tree">, L<"Objects">, +and L<"Stream">. +Custom styles can be provided by giving a full package name containing +at least one '::'. This package should then have subs defined for each +handler it wishes to have installed. See L<"STYLES"> below +for a discussion of each built in style. + +=item * Handlers + +When provided, this option should be an anonymous hash containing as +keys the type of handler and as values a sub reference to handle that +type of event. All the handlers get passed as their 1st parameter the +instance of expat that is parsing the document. Further details on +handlers can be found in L<"HANDLERS">. Any handler set here +overrides the corresponding handler set with the Style option. + +=item * Pkg + +Some styles will refer to subs defined in this package. If not provided, +it defaults to the package which called the constructor. + +=item * ErrorContext + +This is an Expat option. When this option is defined, errors are reported +in context. The value should be the number of lines to show on either side +of the line in which the error occurred. + +=item * ProtocolEncoding + +This is an Expat option. This sets the protocol encoding name. It defaults +to none. The built-in encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and +C<US-ASCII>. Other encodings may be used if they have encoding maps in one +of the directories in the @Encoding_Path list. Check L<"ENCODINGS"> for +more information on encoding maps. Setting the protocol encoding overrides +any encoding in the XML declaration. + +=item * Namespaces + +This is an Expat option. If this is set to a true value, then namespace +processing is done during the parse. See L<XML::Parser::Expat/"Namespaces"> +for further discussion of namespace processing. + +=item * NoExpand + +This is an Expat option. Normally, the parser will try to expand references +to entities defined in the internal subset. If this option is set to a true +value, and a default handler is also set, then the default handler will be +called when an entity reference is seen in text. This has no effect if a +default handler has not been registered, and it has no effect on the expansion +of entity references inside attribute values. + +=item * Stream_Delimiter + +This is an Expat option. It takes a string value. When this string is found +alone on a line while parsing from a stream, then the parse is ended as if it +saw an end of file. The intended use is with a stream of xml documents in a +MIME multipart format. The string should not contain a trailing newline. + +=item * ParseParamEnt + +This is an Expat option. Unless standalone is set to "yes" in the XML +declaration, setting this to a true value allows the external DTD to be read, +and parameter entities to be parsed and expanded. + +=item * NoLWP + +This option has no effect if the ExternEnt or ExternEntFin handlers are +directly set. Otherwise, if true, it forces the use of a file based external +entity handler. + +=item * Non-Expat-Options + +If provided, this should be an anonymous hash whose keys are options that +shouldn't be passed to Expat. This should only be of concern to those +subclassing XML::Parser. + +=back + +=item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]]) + +This method registers handlers for various parser events. It overrides any +previous handlers registered through the Style or Handler options or through +earlier calls to setHandlers. By providing a false or undefined value as +the handler, the existing handler can be unset. + +This method returns a list of type, handler pairs corresponding to the +input. The handlers returned are the ones that were in effect prior to +the call. + +See a description of the handler types in L<"HANDLERS">. + +=item parse(SOURCE [, OPT => OPT_VALUE [...]]) + +The SOURCE parameter should either be a string containing the whole XML +document, or it should be an open IO::Handle. Constructor options to +XML::Parser::Expat given as keyword-value pairs may follow the SOURCE +parameter. These override, for this call, any options or attributes passed +through from the XML::Parser instance. + +A die call is thrown if a parse error occurs. Otherwise it will return 1 +or whatever is returned from the B<Final> handler, if one is installed. +In other words, what parse may return depends on the style. + +=item parsestring + +This is just an alias for parse for backwards compatibility. + +=item parsefile(FILE [, OPT => OPT_VALUE [...]]) + +Open FILE for reading, then call parse with the open handle. The file +is closed no matter how parse returns. Returns what parse returns. + +=item parse_start([ OPT => OPT_VALUE [...]]) + +Create and return a new instance of XML::Parser::ExpatNB. Constructor +options may be provided. If an init handler has been provided, it is +called before returning the ExpatNB object. Documents are parsed by +making incremental calls to the parse_more method of this object, which +takes a string. A single call to the parse_done method of this object, +which takes no arguments, indicates that the document is finished. + +If there is a final handler installed, it is executed by the parse_done +method before returning and the parse_done method returns whatever is +returned by the final handler. + +=back + +=head1 HANDLERS + +Expat is an event based parser. As the parser recognizes parts of the +document (say the start or end tag for an XML element), then any handlers +registered for that type of an event are called with suitable parameters. +All handlers receive an instance of XML::Parser::Expat as their first +argument. See L<XML::Parser::Expat/"METHODS"> for a discussion of the +methods that can be called on this object. + +=head2 Init (Expat) + +This is called just before the parsing of the document starts. + +=head2 Final (Expat) + +This is called just after parsing has finished, but only if no errors +occurred during the parse. Parse returns what this returns. + +=head2 Start (Expat, Element [, Attr, Val [,...]]) + +This event is generated when an XML start tag is recognized. Element is the +name of the XML element type that is opened with the start tag. The Attr & +Val pairs are generated for each attribute in the start tag. + +=head2 End (Expat, Element) + +This event is generated when an XML end tag is recognized. Note that +an XML empty tag (<foo/>) generates both a start and an end event. + +=head2 Char (Expat, String) + +This event is generated when non-markup is recognized. The non-markup +sequence of characters is in String. A single non-markup sequence of +characters may generate multiple calls to this handler. Whatever the +encoding of the string in the original document, this is given to the +handler in UTF-8. + +=head2 Proc (Expat, Target, Data) + +This event is generated when a processing instruction is recognized. + +=head2 Comment (Expat, Data) + +This event is generated when a comment is recognized. + +=head2 CdataStart (Expat) + +This is called at the start of a CDATA section. + +=head2 CdataEnd (Expat) + +This is called at the end of a CDATA section. + +=head2 Default (Expat, String) + +This is called for any characters that don't have a registered handler. +This includes both characters that are part of markup for which no +events are generated (markup declarations) and characters that +could generate events, but for which no handler has been registered. + +Whatever the encoding in the original document, the string is returned to +the handler in UTF-8. + +=head2 Unparsed (Expat, Entity, Base, Sysid, Pubid, Notation) + +This is called for a declaration of an unparsed entity. Entity is the name +of the entity. Base is the base to be used for resolving a relative URI. +Sysid is the system id. Pubid is the public id. Notation is the notation +name. Base and Pubid may be undefined. + +=head2 Notation (Expat, Notation, Base, Sysid, Pubid) + +This is called for a declaration of notation. Notation is the notation name. +Base is the base to be used for resolving a relative URI. Sysid is the system +id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined. + +=head2 ExternEnt (Expat, Base, Sysid, Pubid) + +This is called when an external entity is referenced. Base is the base to be +used for resolving a relative URI. Sysid is the system id. Pubid is the public +id. Base, and Pubid may be undefined. + +This handler should either return a string, which represents the contents of +the external entity, or return an open filehandle that can be read to obtain +the contents of the external entity, or return undef, which indicates the +external entity couldn't be found and will generate a parse error. + +If an open filehandle is returned, it must be returned as either a glob +(*FOO) or as a reference to a glob (e.g. an instance of IO::Handle). + +A default handler is installed for this event. The default handler is +XML::Parser::lwp_ext_ent_handler unless the NoLWP option was provided with +a true value, otherwise XML::Parser::file_ext_ent_handler is the default +handler for external entities. Even without the NoLWP option, if the +URI or LWP modules are missing, the file based handler ends up being used +after giving a warning on the first external entity reference. + +The LWP external entity handler will use proxies defined in the environment +(http_proxy, ftp_proxy, etc.). + +Please note that the LWP external entity handler reads the entire +entity into a string and returns it, where as the file handler opens a +filehandle. + +Also note that the file external entity handler will likely choke on +absolute URIs or file names that don't fit the conventions of the local +operating system. + +The expat base method can be used to set a basename for +relative pathnames. If no basename is given, or if the basename is itself +a relative name, then it is relative to the current working directory. + +=head2 ExternEntFin (Expat) + +This is called after parsing an external entity. It's not called unless +an ExternEnt handler is also set. There is a default handler installed +that pairs with the default ExternEnt handler. + +If you're going to install your own ExternEnt handler, then you should +set (or unset) this handler too. + +=head2 Entity (Expat, Name, Val, Sysid, Pubid, Ndata, IsParam) + +This is called when an entity is declared. For internal entities, the Val +parameter will contain the value and the remaining three parameters will be +undefined. For external entities, the Val parameter will be undefined, the +Sysid parameter will have the system id, the Pubid parameter will have the +public id if it was provided (it will be undefined otherwise), the Ndata +parameter will contain the notation for unparsed entities. If this is a +parameter entity declaration, then the IsParam parameter is true. + +Note that this handler and the Unparsed handler above overlap. If both are +set, then this handler will not be called for unparsed entities. + +=head2 Element (Expat, Name, Model) + +The element handler is called when an element declaration is found. Name +is the element name, and Model is the content model as an XML::Parser::Content +object. See L<XML::Parser::Expat/"XML::Parser::ContentModel Methods"> +for methods available for this class. + +=head2 Attlist (Expat, Elname, Attname, Type, Default, Fixed) + +This handler is called for each attribute in an ATTLIST declaration. +So an ATTLIST declaration that has multiple attributes will generate multiple +calls to this handler. The Elname parameter is the name of the element with +which the attribute is being associated. The Attname parameter is the name +of the attribute. Type is the attribute type, given as a string. Default is +the default value, which will either be "#REQUIRED", "#IMPLIED" or a quoted +string (i.e. the returned string will begin and end with a quote character). +If Fixed is true, then this is a fixed attribute. + +=head2 Doctype (Expat, Name, Sysid, Pubid, Internal) + +This handler is called for DOCTYPE declarations. Name is the document type +name. Sysid is the system id of the document type, if it was provided, +otherwise it's undefined. Pubid is the public id of the document type, +which will be undefined if no public id was given. Internal is the internal +subset, given as a string. If there was no internal subset, it will be +undefined. Internal will contain all whitespace, comments, processing +instructions, and declarations seen in the internal subset. The declarations +will be there whether or not they have been processed by another handler +(except for unparsed entities processed by the Unparsed handler). However, +comments and processing instructions will not appear if they've been processed +by their respective handlers. + +=head2 * DoctypeFin (Parser) + +This handler is called after parsing of the DOCTYPE declaration has finished, +including any internal or external DTD declarations. + +=head2 XMLDecl (Expat, Version, Encoding, Standalone) + +This handler is called for xml declarations. Version is a string containg +the version. Encoding is either undefined or contains an encoding string. +Standalone will be either true, false, or undefined if the standalone attribute +is yes, no, or not made respectively. + +=head1 STYLES + +=head2 Debug + +This just prints out the document in outline form. Nothing special is +returned by parse. + +=head2 Subs + +Each time an element starts, a sub by that name in the package specified +by the Pkg option is called with the same parameters that the Start +handler gets called with. + +Each time an element ends, a sub with that name appended with an underscore +("_"), is called with the same parameters that the End handler gets called +with. + +Nothing special is returned by parse. + +=head2 Tree + +Parse will return a parse tree for the document. Each node in the tree +takes the form of a tag, content pair. Text nodes are represented with +a pseudo-tag of "0" and the string that is their content. For elements, +the content is an array reference. The first item in the array is a +(possibly empty) hash reference containing attributes. The remainder of +the array is a sequence of tag-content pairs representing the content +of the element. + +So for example the result of parsing: + + <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo> + +would be: + Tag Content + ================================================================== + [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]], + bar, [ {}, 0, "Howdy", ref, [{}]], + 0, "do" + ] + ] + +The root document "foo", has 3 children: a "head" element, a "bar" +element and the text "do". After the empty attribute hash, these are +represented in it's contents by 3 tag-content pairs. + +=head2 Objects + +This is similar to the Tree style, except that a hash object is created for +each element. The corresponding object will be in the class whose name +is created by appending "::" and the element name to the package set with +the Pkg option. Non-markup text will be in the ::Characters class. The +contents of the corresponding object will be in an anonymous array that +is the value of the Kids property for that object. + +=head2 Stream + +This style also uses the Pkg package. If none of the subs that this +style looks for is there, then the effect of parsing with this style is +to print a canonical copy of the document without comments or declarations. +All the subs receive as their 1st parameter the Expat instance for the +document they're parsing. + +It looks for the following routines: + +=over 4 + +=item * StartDocument + +Called at the start of the parse . + +=item * StartTag + +Called for every start tag with a second parameter of the element type. The $_ +variable will contain a copy of the tag and the %_ variable will contain +attribute values supplied for that element. + +=item * EndTag + +Called for every end tag with a second parameter of the element type. The $_ +variable will contain a copy of the end tag. + +=item * Text + +Called just before start or end tags with accumulated non-markup text in +the $_ variable. + +=item * PI + +Called for processing instructions. The $_ variable will contain a copy of +the PI and the target and data are sent as 2nd and 3rd parameters +respectively. + +=item * EndDocument + +Called at conclusion of the parse. + +=back + +=head1 ENCODINGS + +XML documents may be encoded in character sets other than Unicode as +long as they may be mapped into the Unicode character set. Expat has +further restrictions on encodings. Read the xmlparse.h header file in +the expat distribution to see details on these restrictions. + +Expat has built-in encodings for: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and +C<US-ASCII>. Encodings are set either through the XML declaration +encoding attribute or through the ProtocolEncoding option to XML::Parser +or XML::Parser::Expat. + +For encodings other than the built-ins, expat calls the function +load_encoding in the Expat package with the encoding name. This function +looks for a file in the path list @XML::Parser::Expat::Encoding_Path, that +matches the lower-cased name with a '.enc' extension. The first one it +finds, it loads. + +If you wish to build your own encoding maps, check out the XML::Encoding +module from CPAN. + +=head1 AUTHORS + +Larry Wall <F<larry@wall.org>> wrote version 1.0. + +Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API +for this version (2.x), provided documentation, +and added some standard package features. + +=cut diff --git a/Master/xemtex/perl/site/lib/XML/Parser/Expat.pm b/Master/xemtex/perl/site/lib/XML/Parser/Expat.pm new file mode 100644 index 00000000000..370f6f67bf6 --- /dev/null +++ b/Master/xemtex/perl/site/lib/XML/Parser/Expat.pm @@ -0,0 +1,1231 @@ +package XML::Parser::Expat; + +require 5.004; + +use strict; +use vars qw($VERSION @ISA %Handler_Setters %Encoding_Table @Encoding_Path + $have_File_Spec); +use Carp; + +use IO::Handle; + +require DynaLoader; + +@ISA = qw(DynaLoader); +$VERSION = "2.31" ; + +$have_File_Spec = $INC{'File/Spec.pm'} || do 'File/Spec.pm'; + +%Encoding_Table = (); +if ($have_File_Spec) { + @Encoding_Path = (grep(-d $_, + map(File::Spec->catdir($_, qw(XML Parser Encodings)), + @INC)), + File::Spec->curdir); +} +else { + @Encoding_Path = (grep(-d $_, map($_ . '/XML/Parser/Encodings', @INC)), '.'); +} + + +bootstrap XML::Parser::Expat $VERSION; + +%Handler_Setters = ( + Start => \&SetStartElementHandler, + End => \&SetEndElementHandler, + Char => \&SetCharacterDataHandler, + Proc => \&SetProcessingInstructionHandler, + Comment => \&SetCommentHandler, + CdataStart => \&SetStartCdataHandler, + CdataEnd => \&SetEndCdataHandler, + Default => \&SetDefaultHandler, + Unparsed => \&SetUnparsedEntityDeclHandler, + Notation => \&SetNotationDeclHandler, + ExternEnt => \&SetExternalEntityRefHandler, + ExternEntFin => \&SetExtEntFinishHandler, + Entity => \&SetEntityDeclHandler, + Element => \&SetElementDeclHandler, + Attlist => \&SetAttListDeclHandler, + Doctype => \&SetDoctypeHandler, + DoctypeFin => \&SetEndDoctypeHandler, + XMLDecl => \&SetXMLDeclHandler + ); + +sub new { + my ($class, %args) = @_; + my $self = bless \%args, $_[0]; + $args{_State_} = 0; + $args{Context} = []; + $args{Namespaces} ||= 0; + $args{ErrorMessage} ||= ''; + if ($args{Namespaces}) { + $args{Namespace_Table} = {}; + $args{Namespace_List} = [undef]; + $args{Prefix_Table} = {}; + $args{New_Prefixes} = []; + } + $args{_Setters} = \%Handler_Setters; + $args{Parser} = ParserCreate($self, $args{ProtocolEncoding}, + $args{Namespaces}); + $self; +} + +sub load_encoding { + my ($file) = @_; + + $file =~ s!([^/]+)$!\L$1\E!; + $file .= '.enc' unless $file =~ /\.enc$/; + unless ($file =~ m!^/!) { + foreach (@Encoding_Path) { + my $tmp = ($have_File_Spec + ? File::Spec->catfile($_, $file) + : "$_/$file"); + if (-e $tmp) { + $file = $tmp; + last; + } + } + } + + local(*ENC); + open(ENC, $file) or croak("Couldn't open encmap $file:\n$!\n"); + binmode(ENC); + my $data; + my $br = sysread(ENC, $data, -s $file); + croak("Trouble reading $file:\n$!\n") + unless defined($br); + close(ENC); + + my $name = LoadEncoding($data, $br); + croak("$file isn't an encmap file") + unless defined($name); + + $name; +} # End load_encoding + +sub setHandlers { + my ($self, @handler_pairs) = @_; + + croak("Uneven number of arguments to setHandlers method") + if (int(@handler_pairs) & 1); + + my @ret; + + while (@handler_pairs) { + my $type = shift @handler_pairs; + my $handler = shift @handler_pairs; + croak "Handler for $type not a Code ref" + unless (! defined($handler) or ! $handler or ref($handler) eq 'CODE'); + + my $hndl = $self->{_Setters}->{$type}; + + unless (defined($hndl)) { + my @types = sort keys %{$self->{_Setters}}; + croak("Unknown Expat handler type: $type\n Valid types: @types"); + } + + my $old = &$hndl($self->{Parser}, $handler); + push (@ret, $type, $old); + } + + return @ret; +} + +sub xpcroak + { + my ($self, $message) = @_; + + my $eclines = $self->{ErrorContext}; + my $line = GetCurrentLineNumber($_[0]->{Parser}); + $message .= " at line $line"; + $message .= ":\n" . $self->position_in_context($eclines) + if defined($eclines); + croak $message; +} + +sub xpcarp { + my ($self, $message) = @_; + + my $eclines = $self->{ErrorContext}; + my $line = GetCurrentLineNumber($_[0]->{Parser}); + $message .= " at line $line"; + $message .= ":\n" . $self->position_in_context($eclines) + if defined($eclines); + carp $message; +} + +sub default_current { + my $self = shift; + if ($self->{_State_} == 1) { + return DefaultCurrent($self->{Parser}); + } +} + +sub recognized_string { + my $self = shift; + if ($self->{_State_} == 1) { + return RecognizedString($self->{Parser}); + } +} + +sub original_string { + my $self = shift; + if ($self->{_State_} == 1) { + return OriginalString($self->{Parser}); + } +} + +sub current_line { + my $self = shift; + if ($self->{_State_} == 1) { + return GetCurrentLineNumber($self->{Parser}); + } +} + +sub current_column { + my $self = shift; + if ($self->{_State_} == 1) { + return GetCurrentColumnNumber($self->{Parser}); + } +} + +sub current_byte { + my $self = shift; + if ($self->{_State_} == 1) { + return GetCurrentByteIndex($self->{Parser}); + } +} + +sub base { + my ($self, $newbase) = @_; + my $p = $self->{Parser}; + my $oldbase = GetBase($p); + SetBase($p, $newbase) if @_ > 1; + return $oldbase; +} + +sub context { + my $ctx = $_[0]->{Context}; + @$ctx; +} + +sub current_element { + my ($self) = @_; + @{$self->{Context}} ? $self->{Context}->[-1] : undef; +} + +sub in_element { + my ($self, $element) = @_; + @{$self->{Context}} ? $self->eq_name($self->{Context}->[-1], $element) + : undef; +} + +sub within_element { + my ($self, $element) = @_; + my $cnt = 0; + foreach (@{$self->{Context}}) { + $cnt++ if $self->eq_name($_, $element); + } + return $cnt; +} + +sub depth { + my ($self) = @_; + int(@{$self->{Context}}); +} + +sub element_index { + my ($self) = @_; + + if ($self->{_State_} == 1) { + return ElementIndex($self->{Parser}); + } +} + +################ +# Namespace methods + +sub namespace { + my ($self, $name) = @_; + local($^W) = 0; + $self->{Namespace_List}->[int($name)]; +} + +sub eq_name { + my ($self, $nm1, $nm2) = @_; + local($^W) = 0; + + int($nm1) == int($nm2) and $nm1 eq $nm2; +} + +sub generate_ns_name { + my ($self, $name, $namespace) = @_; + + $namespace ? + GenerateNSName($name, $namespace, $self->{Namespace_Table}, + $self->{Namespace_List}) + : $name; +} + +sub new_ns_prefixes { + my ($self) = @_; + if ($self->{Namespaces}) { + return @{$self->{New_Prefixes}}; + } + return (); +} + +sub expand_ns_prefix { + my ($self, $prefix) = @_; + + if ($self->{Namespaces}) { + my $stack = $self->{Prefix_Table}->{$prefix}; + return (defined($stack) and @$stack) ? $stack->[-1] : undef; + } + + return undef; +} + +sub current_ns_prefixes { + my ($self) = @_; + + if ($self->{Namespaces}) { + my %set = %{$self->{Prefix_Table}}; + + if (exists $set{'#default'} and not defined($set{'#default'}->[-1])) { + delete $set{'#default'}; + } + + return keys %set; + } + + return (); +} + + +################################################################ +# Namespace declaration handlers +# + +sub NamespaceStart { + my ($self, $prefix, $uri) = @_; + + $prefix = '#default' unless defined $prefix; + my $stack = $self->{Prefix_Table}->{$prefix}; + + if (defined $stack) { + push(@$stack, $uri); + } + else { + $self->{Prefix_Table}->{$prefix} = [$uri]; + } + + # The New_Prefixes list gets emptied at end of startElement function + # in Expat.xs + + push(@{$self->{New_Prefixes}}, $prefix); +} + +sub NamespaceEnd { + my ($self, $prefix) = @_; + + $prefix = '#default' unless defined $prefix; + + my $stack = $self->{Prefix_Table}->{$prefix}; + if (@$stack > 1) { + pop(@$stack); + } + else { + delete $self->{Prefix_Table}->{$prefix}; + } +} + +################ + +sub specified_attr { + my $self = shift; + + if ($self->{_State_} == 1) { + return GetSpecifiedAttributeCount($self->{Parser}); + } +} + +sub finish { + my ($self) = @_; + if ($self->{_State_} == 1) { + my $parser = $self->{Parser}; + UnsetAllHandlers($parser); + } +} + +sub position_in_context { + my ($self, $lines) = @_; + if ($self->{_State_} == 1) { + my $parser = $self->{Parser}; + my ($string, $linepos) = PositionContext($parser, $lines); + + return '' unless defined($string); + + my $col = GetCurrentColumnNumber($parser); + my $ptr = ('=' x ($col - 1)) . '^' . "\n"; + my $ret; + my $dosplit = $linepos < length($string); + + $string .= "\n" unless $string =~ /\n$/; + + if ($dosplit) { + $ret = substr($string, 0, $linepos) . $ptr + . substr($string, $linepos); + } else { + $ret = $string . $ptr; + } + + return $ret; + } +} + +sub xml_escape { + my $self = shift; + my $text = shift; + + study $text; + $text =~ s/\&/\&/g; + $text =~ s/</\</g; + foreach (@_) { + croak "xml_escape: '$_' isn't a single character" if length($_) > 1; + + if ($_ eq '>') { + $text =~ s/>/\>/g; + } + elsif ($_ eq '"') { + $text =~ s/\"/\"/; + } + elsif ($_ eq "'") { + $text =~ s/\'/\'/; + } + else { + my $rep = '&#' . sprintf('x%X', ord($_)) . ';'; + if (/\W/) { + my $ptrn = "\\$_"; + $text =~ s/$ptrn/$rep/g; + } + else { + $text =~ s/$_/$rep/g; + } + } + } + $text; +} + +sub skip_until { + my $self = shift; + if ($self->{_State_} <= 1) { + SkipUntil($self->{Parser}, $_[0]); + } +} + +sub release { + my $self = shift; + ParserRelease($self->{Parser}); +} + +sub DESTROY { + my $self = shift; + ParserFree($self->{Parser}); +} + +sub parse { + my $self = shift; + my $arg = shift; + croak "Parse already in progress (Expat)" if $self->{_State_}; + $self->{_State_} = 1; + my $parser = $self->{Parser}; + my $ioref; + my $result = 0; + + if (defined $arg) { + if (ref($arg) and UNIVERSAL::isa($arg, 'IO::Handle')) { + $ioref = $arg; + } elsif (tied($arg)) { + my $class = ref($arg); + no strict 'refs'; + $ioref = $arg if defined &{"${class}::TIEHANDLE"}; + } + else { + eval { + $ioref = *{$arg}{IO}; + }; + undef $@; + } + } + + if (defined($ioref)) { + my $delim = $self->{Stream_Delimiter}; + my $prev_rs; + + $prev_rs = ref($ioref)->input_record_separator("\n$delim\n") + if defined($delim); + + $result = ParseStream($parser, $ioref, $delim); + + ref($ioref)->input_record_separator($prev_rs) + if defined($delim); + } else { + $result = ParseString($parser, $arg); + } + + $self->{_State_} = 2; + $result or croak $self->{ErrorMessage}; +} + +sub parsestring { + my $self = shift; + $self->parse(@_); +} + +sub parsefile { + my $self = shift; + croak "Parser has already been used" if $self->{_State_}; + local(*FILE); + open(FILE, $_[0]) or croak "Couldn't open $_[0]:\n$!"; + binmode(FILE); + my $ret = $self->parse(*FILE); + close(FILE); + $ret; +} + +################################################################ +package XML::Parser::ContentModel; +use overload '""' => \&asString, 'eq' => \&thiseq; + +sub EMPTY () {1} +sub ANY () {2} +sub MIXED () {3} +sub NAME () {4} +sub CHOICE () {5} +sub SEQ () {6} + + +sub isempty { + return $_[0]->{Type} == EMPTY; +} + +sub isany { + return $_[0]->{Type} == ANY; +} + +sub ismixed { + return $_[0]->{Type} == MIXED; +} + +sub isname { + return $_[0]->{Type} == NAME; +} + +sub name { + return $_[0]->{Tag}; +} + +sub ischoice { + return $_[0]->{Type} == CHOICE; +} + +sub isseq { + return $_[0]->{Type} == SEQ; +} + +sub quant { + return $_[0]->{Quant}; +} + +sub children { + my $children = $_[0]->{Children}; + if (defined $children) { + return @$children; + } + return undef; +} + +sub asString { + my ($self) = @_; + my $ret; + + if ($self->{Type} == NAME) { + $ret = $self->{Tag}; + } + elsif ($self->{Type} == EMPTY) { + return "EMPTY"; + } + elsif ($self->{Type} == ANY) { + return "ANY"; + } + elsif ($self->{Type} == MIXED) { + $ret = '(#PCDATA'; + foreach (@{$self->{Children}}) { + $ret .= '|' . $_; + } + $ret .= ')'; + } + else { + my $sep = $self->{Type} == CHOICE ? '|' : ','; + my @children_str = map { $_->asString } @{$self->{Children}}; + $ret = '(' . join($sep, @children_str) . ')'; + } + + $ret .= $self->{Quant} if $self->{Quant}; + return $ret; +} + +sub thiseq { + my $self = shift; + + return $self->asString eq $_[0]; +} + +################################################################ +package XML::Parser::ExpatNB; + +use vars qw(@ISA); +use Carp; + +@ISA = qw(XML::Parser::Expat); + +sub parse { + my $self = shift; + my $class = ref($self); + croak "parse method not supported in $class"; +} + +sub parsestring { + my $self = shift; + my $class = ref($self); + croak "parsestring method not supported in $class"; +} + +sub parsefile { + my $self = shift; + my $class = ref($self); + croak "parsefile method not supported in $class"; +} + +sub parse_more { + my ($self, $data) = @_; + + $self->{_State_} = 1; + my $ret = XML::Parser::Expat::ParsePartial($self->{Parser}, $data); + + croak $self->{ErrorMessage} unless $ret; +} + +sub parse_done { + my $self = shift; + + my $ret = XML::Parser::Expat::ParseDone($self->{Parser}); + unless ($ret) { + my $msg = $self->{ErrorMessage}; + $self->release; + croak $msg; + } + + $self->{_State_} = 2; + + my $result = $ret; + my @result = (); + my $final = $self->{FinalHandler}; + if (defined $final) { + if (wantarray) { + @result = &$final($self); + } + else { + $result = &$final($self); + } + } + + $self->release; + + return unless defined wantarray; + return wantarray ? @result : $result; +} + +################################################################ + +package XML::Parser::Encinfo; + +sub DESTROY { + my $self = shift; + XML::Parser::Expat::FreeEncoding($self); +} + +1; + +__END__ + +=head1 NAME + +XML::Parser::Expat - Lowlevel access to James Clark's expat XML parser + +=head1 SYNOPSIS + + use XML::Parser::Expat; + + $parser = new XML::Parser::Expat; + $parser->setHandlers('Start' => \&sh, + 'End' => \&eh, + 'Char' => \&ch); + open(FOO, 'info.xml') or die "Couldn't open"; + $parser->parse(*FOO); + close(FOO); + # $parser->parse('<foo id="me"> here <em>we</em> go </foo>'); + + sub sh + { + my ($p, $el, %atts) = @_; + $p->setHandlers('Char' => \&spec) + if ($el eq 'special'); + ... + } + + sub eh + { + my ($p, $el) = @_; + $p->setHandlers('Char' => \&ch) # Special elements won't contain + if ($el eq 'special'); # other special elements + ... + } + +=head1 DESCRIPTION + +This module provides an interface to James Clark's XML parser, expat. As in +expat, a single instance of the parser can only parse one document. Calls +to parsestring after the first for a given instance will die. + +Expat (and XML::Parser::Expat) are event based. As the parser recognizes +parts of the document (say the start or end of an XML element), then any +handlers registered for that type of an event are called with suitable +parameters. + +=head1 METHODS + +=over 4 + +=item new + +This is a class method, the constructor for XML::Parser::Expat. Options are +passed as keyword value pairs. The recognized options are: + +=over 4 + +=item * ProtocolEncoding + +The protocol encoding name. The default is none. The expat built-in +encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and C<US-ASCII>. +Other encodings may be used if they have encoding maps in one of the +directories in the @Encoding_Path list. Setting the protocol encoding +overrides any encoding in the XML declaration. + +=item * Namespaces + +When this option is given with a true value, then the parser does namespace +processing. By default, namespace processing is turned off. When it is +turned on, the parser consumes I<xmlns> attributes and strips off prefixes +from element and attributes names where those prefixes have a defined +namespace. A name's namespace can be found using the L<"namespace"> method +and two names can be checked for absolute equality with the L<"eq_name"> +method. + +=item * NoExpand + +Normally, the parser will try to expand references to entities defined in +the internal subset. If this option is set to a true value, and a default +handler is also set, then the default handler will be called when an +entity reference is seen in text. This has no effect if a default handler +has not been registered, and it has no effect on the expansion of entity +references inside attribute values. + +=item * Stream_Delimiter + +This option takes a string value. When this string is found alone on a line +while parsing from a stream, then the parse is ended as if it saw an end of +file. The intended use is with a stream of xml documents in a MIME multipart +format. The string should not contain a trailing newline. + +=item * ErrorContext + +When this option is defined, errors are reported in context. The value +of ErrorContext should be the number of lines to show on either side of +the line in which the error occurred. + +=item * ParseParamEnt + +Unless standalone is set to "yes" in the XML declaration, setting this to +a true value allows the external DTD to be read, and parameter entities +to be parsed and expanded. + +=item * Base + +The base to use for relative pathnames or URLs. This can also be done by +using the base method. + +=back + +=item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]]) + +This method registers handlers for the various events. If no handlers are +registered, then a call to parsestring or parsefile will only determine if +the corresponding XML document is well formed (by returning without error.) +This may be called from within a handler, after the parse has started. + +Setting a handler to something that evaluates to false unsets that +handler. + +This method returns a list of type, handler pairs corresponding to the +input. The handlers returned are the ones that were in effect before the +call to setHandlers. + +The recognized events and the parameters passed to the corresponding +handlers are: + +=over 4 + +=item * Start (Parser, Element [, Attr, Val [,...]]) + +This event is generated when an XML start tag is recognized. Parser is +an XML::Parser::Expat instance. Element is the name of the XML element that +is opened with the start tag. The Attr & Val pairs are generated for each +attribute in the start tag. + +=item * End (Parser, Element) + +This event is generated when an XML end tag is recognized. Note that +an XML empty tag (<foo/>) generates both a start and an end event. + +There is always a lower level start and end handler installed that wrap +the corresponding callbacks. This is to handle the context mechanism. +A consequence of this is that the default handler (see below) will not +see a start tag or end tag unless the default_current method is called. + +=item * Char (Parser, String) + +This event is generated when non-markup is recognized. The non-markup +sequence of characters is in String. A single non-markup sequence of +characters may generate multiple calls to this handler. Whatever the +encoding of the string in the original document, this is given to the +handler in UTF-8. + +=item * Proc (Parser, Target, Data) + +This event is generated when a processing instruction is recognized. + +=item * Comment (Parser, String) + +This event is generated when a comment is recognized. + +=item * CdataStart (Parser) + +This is called at the start of a CDATA section. + +=item * CdataEnd (Parser) + +This is called at the end of a CDATA section. + +=item * Default (Parser, String) + +This is called for any characters that don't have a registered handler. +This includes both characters that are part of markup for which no +events are generated (markup declarations) and characters that +could generate events, but for which no handler has been registered. + +Whatever the encoding in the original document, the string is returned to +the handler in UTF-8. + +=item * Unparsed (Parser, Entity, Base, Sysid, Pubid, Notation) + +This is called for a declaration of an unparsed entity. Entity is the name +of the entity. Base is the base to be used for resolving a relative URI. +Sysid is the system id. Pubid is the public id. Notation is the notation +name. Base and Pubid may be undefined. + +=item * Notation (Parser, Notation, Base, Sysid, Pubid) + +This is called for a declaration of notation. Notation is the notation name. +Base is the base to be used for resolving a relative URI. Sysid is the system +id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined. + +=item * ExternEnt (Parser, Base, Sysid, Pubid) + +This is called when an external entity is referenced. Base is the base to be +used for resolving a relative URI. Sysid is the system id. Pubid is the public +id. Base, and Pubid may be undefined. + +This handler should either return a string, which represents the contents of +the external entity, or return an open filehandle that can be read to obtain +the contents of the external entity, or return undef, which indicates the +external entity couldn't be found and will generate a parse error. + +If an open filehandle is returned, it must be returned as either a glob +(*FOO) or as a reference to a glob (e.g. an instance of IO::Handle). + +=item * ExternEntFin (Parser) + +This is called after an external entity has been parsed. It allows +applications to perform cleanup on actions performed in the above +ExternEnt handler. + +=item * Entity (Parser, Name, Val, Sysid, Pubid, Ndata, IsParam) + +This is called when an entity is declared. For internal entities, the Val +parameter will contain the value and the remaining three parameters will +be undefined. For external entities, the Val parameter +will be undefined, the Sysid parameter will have the system id, the Pubid +parameter will have the public id if it was provided (it will be undefined +otherwise), the Ndata parameter will contain the notation for unparsed +entities. If this is a parameter entity declaration, then the IsParam +parameter is true. + +Note that this handler and the Unparsed handler above overlap. If both are +set, then this handler will not be called for unparsed entities. + +=item * Element (Parser, Name, Model) + +The element handler is called when an element declaration is found. Name is +the element name, and Model is the content model as an +XML::Parser::ContentModel object. See L<"XML::Parser::ContentModel Methods"> +for methods available for this class. + +=item * Attlist (Parser, Elname, Attname, Type, Default, Fixed) + +This handler is called for each attribute in an ATTLIST declaration. +So an ATTLIST declaration that has multiple attributes +will generate multiple calls to this handler. The Elname parameter is the +name of the element with which the attribute is being associated. The Attname +parameter is the name of the attribute. Type is the attribute type, given as +a string. Default is the default value, which will either be "#REQUIRED", +"#IMPLIED" or a quoted string (i.e. the returned string will begin and end +with a quote character). If Fixed is true, then this is a fixed attribute. + +=item * Doctype (Parser, Name, Sysid, Pubid, Internal) + +This handler is called for DOCTYPE declarations. Name is the document type +name. Sysid is the system id of the document type, if it was provided, +otherwise it's undefined. Pubid is the public id of the document type, +which will be undefined if no public id was given. Internal will be +true or false, indicating whether or not the doctype declaration contains +an internal subset. + +=item * DoctypeFin (Parser) + +This handler is called after parsing of the DOCTYPE declaration has finished, +including any internal or external DTD declarations. + +=item * XMLDecl (Parser, Version, Encoding, Standalone) + +This handler is called for XML declarations. Version is a string containg +the version. Encoding is either undefined or contains an encoding string. +Standalone is either undefined, or true or false. Undefined indicates +that no standalone parameter was given in the XML declaration. True or +false indicates "yes" or "no" respectively. + +=back + +=item namespace(name) + +Return the URI of the namespace that the name belongs to. If the name doesn't +belong to any namespace, an undef is returned. This is only valid on names +received through the Start or End handlers from a single document, or through +a call to the generate_ns_name method. In other words, don't use names +generated from one instance of XML::Parser::Expat with other instances. + +=item eq_name(name1, name2) + +Return true if name1 and name2 are identical (i.e. same name and from +the same namespace.) This is only meaningful if both names were obtained +through the Start or End handlers from a single document, or through +a call to the generate_ns_name method. + +=item generate_ns_name(name, namespace) + +Return a name, associated with a given namespace, good for using with the +above 2 methods. The namespace argument should be the namespace URI, not +a prefix. + +=item new_ns_prefixes + +When called from a start tag handler, returns namespace prefixes declared +with this start tag. If called elsewere (or if there were no namespace +prefixes declared), it returns an empty list. Setting of the default +namespace is indicated with '#default' as a prefix. + +=item expand_ns_prefix(prefix) + +Return the uri to which the given prefix is currently bound. Returns +undef if the prefix isn't currently bound. Use '#default' to find the +current binding of the default namespace (if any). + +=item current_ns_prefixes + +Return a list of currently bound namespace prefixes. The order of the +the prefixes in the list has no meaning. If the default namespace is +currently bound, '#default' appears in the list. + +=item recognized_string + +Returns the string from the document that was recognized in order to call +the current handler. For instance, when called from a start handler, it +will give us the the start-tag string. The string is encoded in UTF-8. +This method doesn't return a meaningful string inside declaration handlers. + +=item original_string + +Returns the verbatim string from the document that was recognized in +order to call the current handler. The string is in the original document +encoding. This method doesn't return a meaningful string inside declaration +handlers. + +=item default_current + +When called from a handler, causes the sequence of characters that generated +the corresponding event to be sent to the default handler (if one is +registered). Use of this method is deprecated in favor the recognized_string +method, which you can use without installing a default handler. This +method doesn't deliver a meaningful string to the default handler when +called from inside declaration handlers. + +=item xpcroak(message) + +Concatenate onto the given message the current line number within the +XML document plus the message implied by ErrorContext. Then croak with +the formed message. + +=item xpcarp(message) + +Concatenate onto the given message the current line number within the +XML document plus the message implied by ErrorContext. Then carp with +the formed message. + +=item current_line + +Returns the line number of the current position of the parse. + +=item current_column + +Returns the column number of the current position of the parse. + +=item current_byte + +Returns the current position of the parse. + +=item base([NEWBASE]); + +Returns the current value of the base for resolving relative URIs. If +NEWBASE is supplied, changes the base to that value. + +=item context + +Returns a list of element names that represent open elements, with the +last one being the innermost. Inside start and end tag handlers, this +will be the tag of the parent element. + +=item current_element + +Returns the name of the innermost currently opened element. Inside +start or end handlers, returns the parent of the element associated +with those tags. + +=item in_element(NAME) + +Returns true if NAME is equal to the name of the innermost currently opened +element. If namespace processing is being used and you want to check +against a name that may be in a namespace, then use the generate_ns_name +method to create the NAME argument. + +=item within_element(NAME) + +Returns the number of times the given name appears in the context list. +If namespace processing is being used and you want to check +against a name that may be in a namespace, then use the generate_ns_name +method to create the NAME argument. + +=item depth + +Returns the size of the context list. + +=item element_index + +Returns an integer that is the depth-first visit order of the current +element. This will be zero outside of the root element. For example, +this will return 1 when called from the start handler for the root element +start tag. + +=item skip_until(INDEX) + +INDEX is an integer that represents an element index. When this method +is called, all handlers are suspended until the start tag for an element +that has an index number equal to INDEX is seen. If a start handler has +been set, then this is the first tag that the start handler will see +after skip_until has been called. + + +=item position_in_context(LINES) + +Returns a string that shows the current parse position. LINES should be +an integer >= 0 that represents the number of lines on either side of the +current parse line to place into the returned string. + +=item xml_escape(TEXT [, CHAR [, CHAR ...]]) + +Returns TEXT with markup characters turned into character entities. Any +additional characters provided as arguments are also turned into character +references where found in TEXT. + +=item parse (SOURCE) + +The SOURCE parameter should either be a string containing the whole XML +document, or it should be an open IO::Handle. Only a single document +may be parsed for a given instance of XML::Parser::Expat, so this will croak +if it's been called previously for this instance. + +=item parsestring(XML_DOC_STRING) + +Parses the given string as an XML document. Only a single document may be +parsed for a given instance of XML::Parser::Expat, so this will die if either +parsestring or parsefile has been called for this instance previously. + +This method is deprecated in favor of the parse method. + +=item parsefile(FILENAME) + +Parses the XML document in the given file. Will die if parsestring or +parsefile has been called previously for this instance. + +=item is_defaulted(ATTNAME) + +NO LONGER WORKS. To find out if an attribute is defaulted please use +the specified_attr method. + +=item specified_attr + +When the start handler receives lists of attributes and values, the +non-defaulted (i.e. explicitly specified) attributes occur in the list +first. This method returns the number of specified items in the list. +So if this number is equal to the length of the list, there were no +defaulted values. Otherwise the number points to the index of the +first defaulted attribute name. + +=item finish + +Unsets all handlers (including internal ones that set context), but expat +continues parsing to the end of the document or until it finds an error. +It should finish up a lot faster than with the handlers set. + +=item release + +There are data structures used by XML::Parser::Expat that have circular +references. This means that these structures will never be garbage +collected unless these references are explicitly broken. Calling this +method breaks those references (and makes the instance unusable.) + +Normally, higher level calls handle this for you, but if you are using +XML::Parser::Expat directly, then it's your responsibility to call it. + +=back + +=head2 XML::Parser::ContentModel Methods + +The element declaration handlers are passed objects of this class as the +content model of the element declaration. They also represent content +particles, components of a content model. + +When referred to as a string, these objects are automagicly converted to a +string representation of the model (or content particle). + +=over 4 + +=item isempty + +This method returns true if the object is "EMPTY", false otherwise. + +=item isany + +This method returns true if the object is "ANY", false otherwise. + +=item ismixed + +This method returns true if the object is "(#PCDATA)" or "(#PCDATA|...)*", +false otherwise. + +=item isname + +This method returns if the object is an element name. + +=item ischoice + +This method returns true if the object is a choice of content particles. + + +=item isseq + +This method returns true if the object is a sequence of content particles. + +=item quant + +This method returns undef or a string representing the quantifier +('?', '*', '+') associated with the model or particle. + +=item children + +This method returns undef or (for mixed, choice, and sequence types) +an array of component content particles. There will always be at least +one component for choices and sequences, but for a mixed content model +of pure PCDATA, "(#PCDATA)", then an undef is returned. + +=back + +=head2 XML::Parser::ExpatNB Methods + +The class XML::Parser::ExpatNB is a subclass of XML::Parser::Expat used +for non-blocking access to the expat library. It does not support the parse, +parsestring, or parsefile methods, but it does have these additional methods: + +=over 4 + +=item parse_more(DATA) + +Feed expat more text to munch on. + +=item parse_done + +Tell expat that it's gotten the whole document. + +=back + +=head1 FUNCTIONS + +=over 4 + +=item XML::Parser::Expat::load_encoding(ENCODING) + +Load an external encoding. ENCODING is either the name of an encoding or +the name of a file. The basename is converted to lowercase and a '.enc' +extension is appended unless there's one already there. Then, unless +it's an absolute pathname (i.e. begins with '/'), the first file by that +name discovered in the @Encoding_Path path list is used. + +The encoding in the file is loaded and kept in the %Encoding_Table +table. Earlier encodings of the same name are replaced. + +This function is automaticly called by expat when it encounters an encoding +it doesn't know about. Expat shouldn't call this twice for the same +encoding name. The only reason users should use this function is to +explicitly load an encoding not contained in the @Encoding_Path list. + +=back + +=head1 AUTHORS + +Larry Wall <F<larry@wall.org>> wrote version 1.0. + +Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API +for this version (2.x), provided documentation, and added some standard +package features. + +=cut diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Bitmap/Bitmap.dll b/Master/xemtex/perl/site/lib/auto/Tk/Bitmap/Bitmap.dll Binary files differnew file mode 100644 index 00000000000..f6b75b704c5 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Bitmap/Bitmap.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al b/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al new file mode 100644 index 00000000000..82105140755 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 405 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\CancelRepeat.al)" +sub CancelRepeat +{ + my $w = shift->MainWindow; + my $id = delete $w->{_afterId_}; + $w->after('cancel',$id) if (defined $id); +} + +# end of Tk::CancelRepeat +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Canvas/Canvas.dll b/Master/xemtex/perl/site/lib/auto/Tk/Canvas/Canvas.dll Binary files differnew file mode 100644 index 00000000000..b6a1321a741 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Canvas/Canvas.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix new file mode 100644 index 00000000000..360e44863af --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix @@ -0,0 +1,6 @@ +# Index created by AutoSplit for blib\lib\Tk/Clipboard.pm +# (file acts as timestamp) +package Tk::Clipboard; +sub getSelected +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/getSelected.al b/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/getSelected.al new file mode 100644 index 00000000000..99d70ee5d76 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/getSelected.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk/Clipboard.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Clipboard; + +#line 103 "blib\lib\Tk/Clipboard.pm (autosplit into blib\lib\auto\Tk\Clipboard\getSelected.al)" +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + +1; +# end of Tk::Clipboard::getSelected diff --git a/Master/xemtex/perl/site/lib/auto/Tk/EnterFocus.al b/Master/xemtex/perl/site/lib/auto/Tk/EnterFocus.al new file mode 100644 index 00000000000..93cc88a8176 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/EnterFocus.al @@ -0,0 +1,26 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 568 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\EnterFocus.al)" +# focusFollowsMouse +# +# If this procedure is invoked, Tk will enter "focus-follows-mouse" +# mode, where the focus is always on whatever window contains the +# mouse. If this procedure isn't invoked, then the user typically +# has to click on a window to give it the focus. +# +# Arguments: +# None. + +sub EnterFocus +{ + my $w = shift; + my $Ev = $w->XEvent; + my $d = $Ev->d; + $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); +} + +# end of Tk::EnterFocus +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Entry/Entry.dll b/Master/xemtex/perl/site/lib/auto/Tk/Entry/Entry.dll Binary files differnew file mode 100644 index 00000000000..dd36353deef --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Entry/Entry.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Error.al b/Master/xemtex/perl/site/lib/auto/Tk/Error.al new file mode 100644 index 00000000000..4d4f06dc941 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Error.al @@ -0,0 +1,20 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 393 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Error.al)" +sub Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; +} + +# end of Tk::Error +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Event/Event.dll b/Master/xemtex/perl/site/lib/auto/Tk/Event/Event.dll Binary files differnew file mode 100644 index 00000000000..2339002b71b --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Event/Event.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al b/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al new file mode 100644 index 00000000000..c5e12b684e7 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al @@ -0,0 +1,21 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 615 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FirstMenu.al)" +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. +sub FirstMenu +{ + my $w = shift; + $w = $w->toplevel->FindMenu(''); +} + +# end of Tk::FirstMenu +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/FocusChildren.al b/Master/xemtex/perl/site/lib/auto/Tk/FocusChildren.al new file mode 100644 index 00000000000..f6d8f6af753 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/FocusChildren.al @@ -0,0 +1,35 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 422 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FocusChildren.al)" +#---------------------------------------------------------------------------- +# focus.tcl -- +# +# This file defines several procedures for managing the input +# focus. +# +# @(#) focus.tcl 1.6 94/12/19 17:06:46 +# +# 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. + +sub FocusChildren { shift->children } + +# +# focusNext -- +# This procedure is invoked to move the input focus to the next window +# after a given one. "Next" is defined in terms of the window +# stacking order, with all the windows underneath a given top-level +# (no matter how deeply nested in the hierarchy) considered except +# for frames and toplevels. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the next window after this one in the traversal +# order. +# end of Tk::FocusChildren +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/FocusOK.al b/Master/xemtex/perl/site/lib/auto/Tk/FocusOK.al new file mode 100644 index 00000000000..bffeffba8f4 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/FocusOK.al @@ -0,0 +1,33 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 542 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\FocusOK.al)" +sub FocusOK +{ + my $w = shift; + my $value; + catch { $value = $w->cget('-takefocus') }; + if (!$@ && defined($value)) + { + return 0 if ($value eq '0'); + return $w->viewable if ($value eq '1'); + $value = $w->$value(); + return $value if (defined $value); + } + if (!$w->viewable) + { + return 0; + } + catch { $value = $w->cget('-state') } ; + if (!$@ && defined($value) && $value eq 'disabled') + { + return 0; + } + $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); + return $value; +} + +# end of Tk::FocusOK +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/AddScrollbars.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/AddScrollbars.al new file mode 100644 index 00000000000..ef3b7537d6e --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/AddScrollbars.al @@ -0,0 +1,52 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 221 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\AddScrollbars.al)" +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]); + } +} + +# end of Tk::Frame::AddScrollbars +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/FindMenu.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/FindMenu.al new file mode 100644 index 00000000000..b82a61da507 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/FindMenu.al @@ -0,0 +1,22 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 359 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\FindMenu.al)" +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; +} + +1; +# end of Tk::Frame::FindMenu diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Frame/autosplit.ix new file mode 100644 index 00000000000..670cd9eb1c4 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/autosplit.ix @@ -0,0 +1,24 @@ +# Index created by AutoSplit for blib\lib\Tk/Frame.pm +# (file acts as timestamp) +package Tk::Frame; +sub labelPack +; +sub labelVariable +; +sub label +; +sub queuePack +; +sub sbset +; +sub freeze_on_map +; +sub AddScrollbars +; +sub packscrollbars +; +sub scrollbars +; +sub FindMenu +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/freeze_on_map.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/freeze_on_map.al new file mode 100644 index 00000000000..61697e647fb --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/freeze_on_map.al @@ -0,0 +1,18 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 211 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\freeze_on_map.al)" +sub freeze_on_map +{ + my ($w) = @_; + unless ($w->Tk::bind('Freeze','<Map>')) + { + $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) + } + $w->AddBindTag('Freeze'); +} + +# end of Tk::Frame::freeze_on_map +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/label.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/label.al new file mode 100644 index 00000000000..3196344c9b8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/label.al @@ -0,0 +1,24 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 178 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\label.al)" +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;; +} + +# end of Tk::Frame::label +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelPack.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelPack.al new file mode 100644 index 00000000000..1dd66963088 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelPack.al @@ -0,0 +1,50 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 117 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\labelPack.al)" +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; +} + +# end of Tk::Frame::labelPack +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelVariable.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelVariable.al new file mode 100644 index 00000000000..6a068e32873 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelVariable.al @@ -0,0 +1,27 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 159 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\labelVariable.al)" +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; +} + +# end of Tk::Frame::labelVariable +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/packscrollbars.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/packscrollbars.al new file mode 100644 index 00000000000..54c59d5bcf2 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/packscrollbars.al @@ -0,0 +1,86 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 265 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\packscrollbars.al)" +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; + } + } +} + +# end of Tk::Frame::packscrollbars +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/queuePack.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/queuePack.al new file mode 100644 index 00000000000..a8a24927d8c --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/queuePack.al @@ -0,0 +1,18 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 194 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\queuePack.al)" +sub queuePack +{ + my ($cw) = @_; + unless ($cw->{'pack_pending'}) + { + $cw->{'pack_pending'} = 1; + $cw->afterIdle([$cw,'packscrollbars']); + } +} + +# end of Tk::Frame::queuePack +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/sbset.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/sbset.al new file mode 100644 index 00000000000..357fcfd4a4e --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/sbset.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 204 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\sbset.al)" +sub sbset +{ + my ($cw,$sb,$ref,@args) = @_; + $sb->set(@args); + $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); +} + +# end of Tk::Frame::sbset +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Frame/scrollbars.al b/Master/xemtex/perl/site/lib/auto/Tk/Frame/scrollbars.al new file mode 100644 index 00000000000..2a4706eb198 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Frame/scrollbars.al @@ -0,0 +1,24 @@ +# NOTE: Derived from blib\lib\Tk/Frame.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Frame; + +#line 343 "blib\lib\Tk/Frame.pm (autosplit into blib\lib\auto\Tk\Frame\scrollbars.al)" +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; +} + +# end of Tk::Frame::scrollbars +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/ImageNames.al b/Master/xemtex/perl/site/lib/auto/Tk/ImageNames.al new file mode 100644 index 00000000000..2a4bd24818a --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/ImageNames.al @@ -0,0 +1,13 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 667 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\ImageNames.al)" +sub ImageNames +{ + image('names'); +} + +# end of Tk::ImageNames +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/ImageTypes.al b/Master/xemtex/perl/site/lib/auto/Tk/ImageTypes.al new file mode 100644 index 00000000000..0f9b8be674a --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/ImageTypes.al @@ -0,0 +1,13 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 672 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\ImageTypes.al)" +sub ImageTypes +{ + image('types'); +} + +# end of Tk::ImageTypes +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/AutoScan.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/AutoScan.al new file mode 100644 index 00000000000..e366618df81 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/AutoScan.al @@ -0,0 +1,48 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 634 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\AutoScan.al)" +# 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)); +} + +# end of Tk::Listbox::AutoScan +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginExtend.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginExtend.al new file mode 100644 index 00000000000..ad3fe4c6d33 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginExtend.al @@ -0,0 +1,29 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 584 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginExtend.al)" +# 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) + } +} + +# end of Tk::Listbox::BeginExtend +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginSelect.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginSelect.al new file mode 100644 index 00000000000..b29359c70c5 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginSelect.al @@ -0,0 +1,45 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 491 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginSelect.al)" +# 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')); +} + +# end of Tk::Listbox::BeginSelect +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginToggle.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginToggle.al new file mode 100644 index 00000000000..3f7ddff4cf9 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginToggle.al @@ -0,0 +1,39 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 604 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\BeginToggle.al)" +# 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) + } + } +} + +# end of Tk::Listbox::BeginToggle +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al new file mode 100644 index 00000000000..7461080092f --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al @@ -0,0 +1,16 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 450 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\ButtonRelease_1.al)" +sub ButtonRelease_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->CancelRepeat; + $w->activate($Ev->xy); +} + +# end of Tk::Listbox::ButtonRelease_1 +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cancel.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cancel.al new file mode 100644 index 00000000000..3974c2e145c --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cancel.al @@ -0,0 +1,43 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 754 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cancel.al)" +# 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 + } +} + +# end of Tk::Listbox::Cancel +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_End.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_End.al new file mode 100644 index 00000000000..de53c8048aa --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_End.al @@ -0,0 +1,18 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 470 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_End.al)" +sub Cntrl_End +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate('end'); + $w->see('end'); + $w->selectionClear(0,'end'); + $w->selectionSet('end') +} + +# end of Tk::Listbox::Cntrl_End +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_Home.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_Home.al new file mode 100644 index 00000000000..34f09d21bb9 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_Home.al @@ -0,0 +1,18 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 459 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_Home.al)" +sub Cntrl_Home +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->activate(0); + $w->see(0); + $w->selectionClear(0,'end'); + $w->selectionSet(0) +} + +# end of Tk::Listbox::Cntrl_Home +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al new file mode 100644 index 00000000000..382a68528a8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al @@ -0,0 +1,18 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 481 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Cntrl_backslash.al)" +sub Cntrl_backslash +{ + my $w = shift; + my $Ev = $w->XEvent; + if ($w->cget('-selectmode') ne 'browse') + { + $w->selectionClear(0,'end'); + } +} + +# end of Tk::Listbox::Cntrl_backslash +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/DataExtend.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/DataExtend.al new file mode 100644 index 00000000000..fdeb0368bba --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/DataExtend.al @@ -0,0 +1,39 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 724 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\DataExtend.al)" +# 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) + } +} + +# end of Tk::Listbox::DataExtend +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ExtendUpDown.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ExtendUpDown.al new file mode 100644 index 00000000000..9c21c0a93a1 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ExtendUpDown.al @@ -0,0 +1,30 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 703 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\ExtendUpDown.al)" +# 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')) +} + +# end of Tk::Listbox::ExtendUpDown +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Listbox.dll b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Listbox.dll Binary files differnew file mode 100644 index 00000000000..de4907125a9 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Listbox.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al new file mode 100644 index 00000000000..d67ec8121d9 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al @@ -0,0 +1,66 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 527 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\Motion.al)" +# 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 + } +} + +# end of Tk::Listbox::Motion +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SelectAll.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SelectAll.al new file mode 100644 index 00000000000..319ce5c2a9c --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SelectAll.al @@ -0,0 +1,31 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 788 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SelectAll.al)" +# 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') + } +} + +# end of Tk::Listbox::SelectAll +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SetList.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SetList.al new file mode 100644 index 00000000000..5f4ba81ddf3 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SetList.al @@ -0,0 +1,15 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 811 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\SetList.al)" +sub SetList +{ + my $w = shift; + $w->delete(0,'end'); + $w->insert('end',@_); +} + +# end of Tk::Listbox::SetList +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/UpDown.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/UpDown.al new file mode 100644 index 00000000000..e2ce7edce78 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/UpDown.al @@ -0,0 +1,39 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 673 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\UpDown.al)" +# 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 = (); + } +} + +# end of Tk::Listbox::UpDown +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/autosplit.ix new file mode 100644 index 00000000000..5846f38c4ce --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/autosplit.ix @@ -0,0 +1,42 @@ +# Index created by AutoSplit for ..\blib\lib\Tk\Listbox.pm +# (file acts as timestamp) +package Tk::Listbox; +sub xyIndex +; +sub ButtonRelease_1 +; +sub Cntrl_Home +; +sub Cntrl_End +; +sub Cntrl_backslash +; +sub BeginSelect +; +sub Motion +; +sub BeginExtend +; +sub BeginToggle +; +sub AutoScan +; +sub UpDown +; +sub ExtendUpDown +; +sub DataExtend +; +sub Cancel +; +sub SelectAll +; +sub SetList +; +sub deleteSelected +; +sub clipboardPaste +; +sub getSelected +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/clipboardPaste.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/clipboardPaste.al new file mode 100644 index 00000000000..7deae1e75a4 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/clipboardPaste.al @@ -0,0 +1,21 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 828 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\clipboardPaste.al)" +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++,$_); + } +} + +# end of Tk::Listbox::clipboardPaste +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/deleteSelected.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/deleteSelected.al new file mode 100644 index 00000000000..6fc89af9e91 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/deleteSelected.al @@ -0,0 +1,18 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 818 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\deleteSelected.al)" +sub deleteSelected +{ + my $w = shift; + my $i; + foreach $i (reverse $w->curselection) + { + $w->delete($i); + } +} + +# end of Tk::Listbox::deleteSelected +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/getSelected.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/getSelected.al new file mode 100644 index 00000000000..64706cfa9b4 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/getSelected.al @@ -0,0 +1,22 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 841 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\getSelected.al)" +sub getSelected +{ + my ($w) = @_; + my $i; + my (@result) = (); + foreach $i ($w->curselection) + { + push(@result,$w->get($i)); + } + return (wantarray) ? @result : $result[0]; +} + +1; +__END__ +1; +# end of Tk::Listbox::getSelected diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/xyIndex.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/xyIndex.al new file mode 100644 index 00000000000..bfd364a7f9b --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/xyIndex.al @@ -0,0 +1,27 @@ +# NOTE: Derived from ..\blib\lib\Tk\Listbox.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Listbox; + +#line 431 "..\blib\lib\Tk\Listbox.pm (autosplit into ..\blib\lib\auto\Tk\Listbox\xyIndex.al)" +# +# 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); +} + +# end of Tk::Listbox::xyIndex +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Menubutton/Menubutton.dll b/Master/xemtex/perl/site/lib/auto/Tk/Menubutton/Menubutton.dll Binary files differnew file mode 100644 index 00000000000..f05f347cc8b --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Menubutton/Menubutton.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll b/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll Binary files differnew file mode 100644 index 00000000000..0e887aaefc3 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Receive.al b/Master/xemtex/perl/site/lib/auto/Tk/Receive.al new file mode 100644 index 00000000000..e33b6bdc1af --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Receive.al @@ -0,0 +1,23 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 638 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Receive.al)" +# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) +# calls it when it does its eval "require $base" +#sub Clipboard +#{my $w = shift; +# my $cmd = shift; +# croak "Use clipboard\u$cmd()"; +#} + +sub Receive +{ + my $w = shift; + warn 'Receive(' . join(',',@_) .')'; + die 'Tk rejects send(' . join(',',@_) .")\n"; +} + +# end of Tk::Receive +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/RepeatId.al b/Master/xemtex/perl/site/lib/auto/Tk/RepeatId.al new file mode 100644 index 00000000000..06728f02221 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/RepeatId.al @@ -0,0 +1,16 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 412 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\RepeatId.al)" +sub RepeatId +{ + my ($w,$id) = @_; + $w = $w->MainWindow; + $w->CancelRepeat; + $w->{_afterId_} = $id; +} + +# end of Tk::RepeatId +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Activate.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Activate.al new file mode 100644 index 00000000000..500358c8e0e --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Activate.al @@ -0,0 +1,33 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 86 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Activate.al)" +# 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') + } +} + +# end of Tk::Scale::Activate +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonDown.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonDown.al new file mode 100644 index 00000000000..61ed6f32c11 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonDown.al @@ -0,0 +1,40 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 138 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ButtonDown.al)" +# 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]; + } +} + +# end of Tk::Scale::ButtonDown +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonUp.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonUp.al new file mode 100644 index 00000000000..d5a22a77a46 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonUp.al @@ -0,0 +1,16 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 129 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ButtonUp.al)" +sub ButtonUp +{ + my ($w,$x,$y) = @_; + $w->CancelRepeat(); + $w->EndDrag(); + $w->Activate($x,$y) +} + +# end of Tk::Scale::ButtonUp +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ControlPress.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ControlPress.al new file mode 100644 index 00000000000..50d7ad8b447 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/ControlPress.al @@ -0,0 +1,31 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 255 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\ControlPress.al)" +# 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')) + } +} + +1; +# end of Tk::Scale::ControlPress diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Drag.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Drag.al new file mode 100644 index 00000000000..0bc63b12879 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Drag.al @@ -0,0 +1,29 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 169 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Drag.al)" +# 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)) +} + +# end of Tk::Scale::Drag +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/EndDrag.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/EndDrag.al new file mode 100644 index 00000000000..86037b86d92 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/EndDrag.al @@ -0,0 +1,23 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 189 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\EndDrag.al)" +# 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; +} + +# end of Tk::Scale::EndDrag +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Enter.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Enter.al new file mode 100644 index 00000000000..1326a5ed9a0 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Enter.al @@ -0,0 +1,19 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 118 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Enter.al)" +sub Enter +{ + my ($w,$x,$y) = @_; + if ($Tk::strictMotif) + { + $w->{'activeBg'} = $w->cget('-activebackground'); + $w->configure('-activebackground',$w->cget('-background')); + } + $w->Activate($x,$y); +} + +# end of Tk::Scale::Enter +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Increment.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Increment.al new file mode 100644 index 00000000000..76432eeaf40 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Increment.al @@ -0,0 +1,61 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 203 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Increment.al)" +# 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')); + } +} + +# end of Tk::Scale::Increment +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Leave.al b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Leave.al new file mode 100644 index 00000000000..eb6f7b69f89 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Leave.al @@ -0,0 +1,15 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scale.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scale; + +#line 111 "..\blib\lib\Tk\Scale.pm (autosplit into ..\blib\lib\auto\Tk\Scale\Leave.al)" +sub Leave +{ + my ($w) = @_; + $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif); + $w->configure('-state','normal') if ($w->cget('-state') eq 'active'); +} + +# end of Tk::Scale::Leave +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Scale.dll b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Scale.dll Binary files differnew file mode 100644 index 00000000000..ff1568bcfe6 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/Scale.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix new file mode 100644 index 00000000000..a5c5d2292f2 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix @@ -0,0 +1,22 @@ +# Index created by AutoSplit for ..\blib\lib\Tk\Scale.pm +# (file acts as timestamp) +package Tk::Scale; +sub Activate +; +sub Leave +; +sub Enter +; +sub ButtonUp +; +sub ButtonDown +; +sub Drag +; +sub EndDrag +; +sub Increment +; +sub ControlPress +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonDown.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonDown.al new file mode 100644 index 00000000000..c17199b73b6 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonDown.al @@ -0,0 +1,55 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 106 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ButtonDown.al)" +# 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'); + } +} + +# end of Tk::Scrollbar::ButtonDown +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonUp.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonUp.al new file mode 100644 index 00000000000..24058d857ec --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonUp.al @@ -0,0 +1,26 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 153 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ButtonUp.al)" +# 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)); +} + +# end of Tk::Scrollbar::ButtonUp +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Drag.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Drag.al new file mode 100644 index 00000000000..40d6b0f8d1b --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Drag.al @@ -0,0 +1,44 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 247 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Drag.al)" +# 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); + } +} + +# end of Tk::Scrollbar::Drag +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/EndDrag.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/EndDrag.al new file mode 100644 index 00000000000..5b1fc837326 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/EndDrag.al @@ -0,0 +1,29 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 283 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\EndDrag.al)" +# 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; +} + +# end of Tk::Scrollbar::EndDrag +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Enter.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Enter.al new file mode 100644 index 00000000000..45a21f920e5 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Enter.al @@ -0,0 +1,21 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 76 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Enter.al)" +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)); +} + +# end of Tk::Scrollbar::Enter +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Leave.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Leave.al new file mode 100644 index 00000000000..349911e304e --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Leave.al @@ -0,0 +1,18 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 89 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Leave.al)" +sub Leave +{ + my $w = shift; + if ($Tk::strictMotif) + { + $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ; + } + $w->activate(''); +} + +# end of Tk::Scrollbar::Leave +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Motion.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Motion.al new file mode 100644 index 00000000000..0b414efa389 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Motion.al @@ -0,0 +1,15 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 99 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Motion.al)" +sub Motion +{ + my $w = shift; + my $e = $w->XEvent; + $w->activate($w->identify($e->x,$e->y)); +} + +# end of Tk::Scrollbar::Motion +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al new file mode 100644 index 00000000000..bd3d29afa77 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al @@ -0,0 +1,38 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 333 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlByPages.al)" +# 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)); + } +} + +# end of Tk::Scrollbar::ScrlByPages +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al new file mode 100644 index 00000000000..99e84e394c5 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al @@ -0,0 +1,37 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 304 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlByUnits.al)" +# 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); + } +} + +# end of Tk::Scrollbar::ScrlByUnits +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al new file mode 100644 index 00000000000..c3a25af3c19 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al @@ -0,0 +1,35 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 363 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlToPos.al)" +# 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)); + } +} + +# end of Tk::Scrollbar::ScrlToPos +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al new file mode 100644 index 00000000000..71be23e6794 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al @@ -0,0 +1,32 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 390 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\ScrlTopBottom.al)" +# 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); + } +} + +1; +# end of Tk::Scrollbar::ScrlTopBottom diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll Binary files differnew file mode 100644 index 00000000000..81eec672093 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al new file mode 100644 index 00000000000..21a743bf7fd --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al @@ -0,0 +1,59 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 171 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\Select.al)" +# 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'])); + } +} + +# end of Tk::Scrollbar::Select +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/StartDrag.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/StartDrag.al new file mode 100644 index 00000000000..d544dc53945 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/StartDrag.al @@ -0,0 +1,33 @@ +# NOTE: Derived from ..\blib\lib\Tk\Scrollbar.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Scrollbar; + +#line 222 "..\blib\lib\Tk\Scrollbar.pm (autosplit into ..\blib\lib\auto\Tk\Scrollbar\StartDrag.al)" +# 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]; + } +} + +# end of Tk::Scrollbar::StartDrag +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/autosplit.ix new file mode 100644 index 00000000000..293d1322dd4 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/autosplit.ix @@ -0,0 +1,30 @@ +# Index created by AutoSplit for ..\blib\lib\Tk\Scrollbar.pm +# (file acts as timestamp) +package Tk::Scrollbar; +sub Enter +; +sub Leave +; +sub Motion +; +sub ButtonDown +; +sub ButtonUp +; +sub Select +; +sub StartDrag +; +sub Drag +; +sub EndDrag +; +sub ScrlByUnits +; +sub ScrlByPages +; +sub ScrlToPos +; +sub ScrlTopBottom +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Selection.al b/Master/xemtex/perl/site/lib/auto/Tk/Selection.al new file mode 100644 index 00000000000..0d50a9f31df --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Selection.al @@ -0,0 +1,18 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 628 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Selection.al)" +# These wrappers don't use method syntax so need to live +# in same package as raw Tk routines are newXS'ed into. + +sub Selection +{my $widget = shift; + my $cmd = shift; + croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); + croak "Use Selection\u$cmd()"; +} + +# end of Tk::Selection +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Text/Text.dll b/Master/xemtex/perl/site/lib/auto/Tk/Text/Text.dll Binary files differnew file mode 100644 index 00000000000..8cb98c8a455 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Text/Text.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix new file mode 100644 index 00000000000..48a5455c34a --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix @@ -0,0 +1,3 @@ +# Index created by AutoSplit for ..\blib\lib\Tk\Text.pm +# (file acts as timestamp) +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Tk.dll b/Master/xemtex/perl/site/lib/auto/Tk/Tk.dll Binary files differnew file mode 100644 index 00000000000..ee55846fdcb --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Tk.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindIn.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindIn.al new file mode 100644 index 00000000000..cc2ceaf7b63 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindIn.al @@ -0,0 +1,19 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 128 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_BindIn.al)" +# 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); +} + +# end of Tk::Toplevel::FG_BindIn +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindOut.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindOut.al new file mode 100644 index 00000000000..5c5cf9cc3de --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindOut.al @@ -0,0 +1,20 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 139 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_BindOut.al)" +# 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); +} + +# end of Tk::Toplevel::FG_BindOut +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Create.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Create.al new file mode 100644 index 00000000000..0953c045be8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Create.al @@ -0,0 +1,56 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 80 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Create.al)" +#---------------------------------------------------------------------- +# +# 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']); + } +} + +# end of Tk::Toplevel::FG_Create +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Destroy.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Destroy.al new file mode 100644 index 00000000000..e20f1eb7568 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Destroy.al @@ -0,0 +1,29 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 151 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Destroy.al)" +# 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}; + } +} + +# end of Tk::Toplevel::FG_Destroy +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_In.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_In.al new file mode 100644 index 00000000000..a4b5c67a155 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_In.al @@ -0,0 +1,24 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 172 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_In.al)" +# 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}; + } +} + +# end of Tk::Toplevel::FG_In +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Out.al b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Out.al new file mode 100644 index 00000000000..96a3841e6fd --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Out.al @@ -0,0 +1,32 @@ +# NOTE: Derived from blib\lib\Tk/Toplevel.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Toplevel; + +#line 188 "blib\lib\Tk/Toplevel.pm (autosplit into blib\lib\auto\Tk\Toplevel\FG_Out.al)" +# 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__ +1; +# end of Tk::Toplevel::FG_Out diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/autosplit.ix new file mode 100644 index 00000000000..6267c58604c --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/autosplit.ix @@ -0,0 +1,10 @@ +# Index created by AutoSplit for blib\lib\Tk/Toplevel.pm +# (file acts as timestamp) +package Tk::Toplevel; +sub FG_Create ; +sub FG_BindIn ; +sub FG_BindOut ; +sub FG_Destroy ; +sub FG_In ; +sub FG_Out ; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/TraverseToMenu.al b/Master/xemtex/perl/site/lib/auto/Tk/TraverseToMenu.al new file mode 100644 index 00000000000..03b814a1334 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/TraverseToMenu.al @@ -0,0 +1,27 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 597 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\TraverseToMenu.al)" +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. +sub TraverseToMenu +{ + my $w = shift; + my $char = shift; + return unless(defined $char && $char ne ''); + $w = $w->toplevel->FindMenu($char); +} + +# end of Tk::TraverseToMenu +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Widget/ASkludge.al b/Master/xemtex/perl/site/lib/auto/Tk/Widget/ASkludge.al new file mode 100644 index 00000000000..fe9b23df886 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Widget/ASkludge.al @@ -0,0 +1,30 @@ +# NOTE: Derived from blib\lib\Tk/Widget.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Widget; + +#line 1224 "blib\lib\Tk/Widget.pm (autosplit into blib\lib\auto\Tk\Widget\ASkludge.al)" +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}}; + } + } + } +} + +# end of Tk::Widget::ASkludge +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Widget/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Widget/autosplit.ix new file mode 100644 index 00000000000..f0a7ffb9891 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Widget/autosplit.ix @@ -0,0 +1,10 @@ +# Index created by AutoSplit for blib\lib\Tk/Widget.pm +# (file acts as timestamp) +package Tk::Widget; +sub ASkludge +; +sub clipboardKeysyms +; +sub pathname +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Widget/clipboardKeysyms.al b/Master/xemtex/perl/site/lib/auto/Tk/Widget/clipboardKeysyms.al new file mode 100644 index 00000000000..71996befb5f --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Widget/clipboardKeysyms.al @@ -0,0 +1,51 @@ +# NOTE: Derived from blib\lib\Tk/Widget.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Widget; + +#line 1248 "blib\lib\Tk/Widget.pm (autosplit into blib\lib\auto\Tk\Widget\clipboardKeysyms.al)" +# 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); + } +} + +# end of Tk::Widget::clipboardKeysyms +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Widget/pathname.al b/Master/xemtex/perl/site/lib/auto/Tk/Widget/pathname.al new file mode 100644 index 00000000000..e22439a73cd --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Widget/pathname.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk/Widget.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Widget; + +#line 1291 "blib\lib\Tk/Widget.pm (autosplit into blib\lib\auto\Tk\Widget\pathname.al)" +sub pathname +{ + my ($w,$id) = @_; + my $x = $w->winfo('pathname',-displayof => oct($id)); + return $x->PathName; +} + +1; +# end of Tk::Widget::pathname diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/AnchorAdjust.al b/Master/xemtex/perl/site/lib/auto/Tk/Wm/AnchorAdjust.al new file mode 100644 index 00000000000..a699cee6920 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/AnchorAdjust.al @@ -0,0 +1,17 @@ +# NOTE: Derived from blib\lib\Tk/Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 84 "blib\lib\Tk/Wm.pm (autosplit into blib\lib\auto\Tk\Wm\AnchorAdjust.al)" +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); +} + +# end of Tk::Wm::AnchorAdjust +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/FullScreen.al b/Master/xemtex/perl/site/lib/auto/Tk/Wm/FullScreen.al new file mode 100644 index 00000000000..83ab7a3241c --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/FullScreen.al @@ -0,0 +1,29 @@ +# NOTE: Derived from blib\lib\Tk/Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 130 "blib\lib\Tk/Wm.pm (autosplit into blib\lib\auto\Tk\Wm\FullScreen.al)" +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; + } +} + +# end of Tk::Wm::FullScreen +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/Popup.al b/Master/xemtex/perl/site/lib/auto/Tk/Wm/Popup.al new file mode 100644 index 00000000000..59a6f496d53 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/Popup.al @@ -0,0 +1,45 @@ +# NOTE: Derived from blib\lib\Tk/Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 93 "blib\lib\Tk/Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Popup.al)" +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; +} + +# end of Tk::Wm::Popup +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/Post.al b/Master/xemtex/perl/site/lib/auto/Tk/Wm/Post.al new file mode 100644 index 00000000000..277981329b0 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/Post.al @@ -0,0 +1,20 @@ +# NOTE: Derived from blib\lib\Tk/Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 72 "blib\lib\Tk/Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Post.al)" +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; +} + +# end of Tk::Wm::Post +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Wm/autosplit.ix new file mode 100644 index 00000000000..54b764985de --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/autosplit.ix @@ -0,0 +1,14 @@ +# Index created by AutoSplit for blib\lib\Tk/Wm.pm +# (file acts as timestamp) +package Tk::Wm; +sub Post +; +sub AnchorAdjust +; +sub Popup +; +sub FullScreen +; +sub iconposition +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Wm/iconposition.al b/Master/xemtex/perl/site/lib/auto/Tk/Wm/iconposition.al new file mode 100644 index 00000000000..6a5b0ec92d8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/Wm/iconposition.al @@ -0,0 +1,24 @@ +# NOTE: Derived from blib\lib\Tk/Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 151 "blib\lib\Tk/Wm.pm (autosplit into blib\lib\auto\Tk\Wm\iconposition.al)" +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',@_); +} + +1; +# end of Tk::Wm::iconposition diff --git a/Master/xemtex/perl/site/lib/auto/Tk/X/X.dll b/Master/xemtex/perl/site/lib/auto/Tk/X/X.dll Binary files differnew file mode 100644 index 00000000000..81c220688ae --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/X/X.dll diff --git a/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix new file mode 100644 index 00000000000..e63dbf19b00 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix @@ -0,0 +1,3 @@ +# Index created by AutoSplit for ..\..\blib\lib\Tk\X.pm +# (file acts as timestamp) +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/autosplit.ix new file mode 100644 index 00000000000..8e8d2880a02 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/autosplit.ix @@ -0,0 +1,43 @@ +# Index created by AutoSplit for blib\lib\Tk.pm +# (file acts as timestamp) +package Tk; +sub Error +; +sub CancelRepeat +; +sub RepeatId +; +sub FocusChildren ; +sub focusNext +; +sub focusPrev +; +sub FocusOK +; +sub EnterFocus +; +sub tabFocus +; +sub focusFollowsMouse +; +sub TraverseToMenu +; +sub FirstMenu +; +sub Selection +; +sub Receive +; +sub break +; +sub updateWidgets +; +sub ImageNames +; +sub ImageTypes +; +sub interps +; +sub lsearch +; +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/break.al b/Master/xemtex/perl/site/lib/auto/Tk/break.al new file mode 100644 index 00000000000..388cd46b21b --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/break.al @@ -0,0 +1,13 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 653 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\break.al)" +sub break +{ + die "_TK_BREAK_\n"; +} + +# end of Tk::break +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/focusFollowsMouse.al b/Master/xemtex/perl/site/lib/auto/Tk/focusFollowsMouse.al new file mode 100644 index 00000000000..697e8c61fae --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/focusFollowsMouse.al @@ -0,0 +1,14 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 591 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusFollowsMouse.al)" +sub focusFollowsMouse +{ + my $widget = shift; + $widget->bind('all','<Enter>','EnterFocus'); +} + +# end of Tk::focusFollowsMouse +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/focusNext.al b/Master/xemtex/perl/site/lib/auto/Tk/focusNext.al new file mode 100644 index 00000000000..b5dbc9bc7d6 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/focusNext.al @@ -0,0 +1,45 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 449 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusNext.al)" +sub focusNext +{ + my $w = shift; + my $cur = $w; + while (1) + { + # Descend to just before the first child of the current widget. + my $parent = $cur; + my @children = $cur->FocusChildren(); + my $i = -1; + # Look for the next sibling that isn't a top-level. + while (1) + { + $i += 1; + if ($i < @children) + { + $cur = $children[$i]; + next if ($cur->toplevel == $cur); + last + } + # No more siblings, so go to the current widget's parent. + # If it's a top-level, break out of the loop, otherwise + # look for its next sibling. + $cur = $parent; + last if ($cur->toplevel() == $cur); + $parent = $parent->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } +} + +# end of Tk::focusNext +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/focusPrev.al b/Master/xemtex/perl/site/lib/auto/Tk/focusPrev.al new file mode 100644 index 00000000000..77aadf1b929 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/focusPrev.al @@ -0,0 +1,65 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 485 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\focusPrev.al)" +# focusPrev -- +# This procedure is invoked to move the input focus to the previous +# window before a given one. "Previous" is defined in terms of the +# window stacking order, with all the windows underneath a given +# top-level (no matter how deeply nested in the hierarchy) considered. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the previous window before this one in the traversal +# order. +sub focusPrev +{ + my $w = shift; + my $cur = $w; + my @children; + my $i; + my $parent; + while (1) + { + # Collect information about the current window's position + # among its siblings. Also, if the window is a top-level, + # then reposition to just after the last child of the window. + if ($cur->toplevel() == $cur) + { + $parent = $cur; + @children = $cur->FocusChildren(); + $i = @children; + } + else + { + $parent = $cur->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + # Go to the previous sibling, then descend to its last descendant + # (highest in stacking order. While doing this, ignore top-levels + # and their descendants. When we run out of descendants, go up + # one level to the parent. + while ($i > 0) + { + $i--; + $cur = $children[$i]; + next if ($cur->toplevel() == $cur); + $parent = $cur; + @children = $parent->FocusChildren(); + $i = @children; + } + $cur = $parent; + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } + +} + +# end of Tk::focusPrev +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/interps.al b/Master/xemtex/perl/site/lib/auto/Tk/interps.al new file mode 100644 index 00000000000..fe01aa3099f --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/interps.al @@ -0,0 +1,14 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 677 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\interps.al)" +sub interps +{ + my $w = shift; + return $w->winfo('interps','-displayof'); +} + +# end of Tk::interps +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/lsearch.al b/Master/xemtex/perl/site/lib/auto/Tk/lsearch.al new file mode 100644 index 00000000000..7a597051bec --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/lsearch.al @@ -0,0 +1,19 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 683 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\lsearch.al)" +sub lsearch +{my $ar = shift; + my $x = shift; + my $i; + for ($i = 0; $i < scalar @$ar; $i++) + { + return $i if ($$ar[$i] eq $x); + } + return -1; +} + +1; +# end of Tk::lsearch diff --git a/Master/xemtex/perl/site/lib/auto/Tk/tabFocus.al b/Master/xemtex/perl/site/lib/auto/Tk/tabFocus.al new file mode 100644 index 00000000000..4016abff331 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/tabFocus.al @@ -0,0 +1,13 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 586 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\tabFocus.al)" +sub tabFocus +{ + shift->Tk::focus; +} + +# end of Tk::tabFocus +1; diff --git a/Master/xemtex/perl/site/lib/auto/Tk/updateWidgets.al b/Master/xemtex/perl/site/lib/auto/Tk/updateWidgets.al new file mode 100644 index 00000000000..0fec5abb3c8 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Tk/updateWidgets.al @@ -0,0 +1,17 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 658 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\updateWidgets.al)" +sub updateWidgets +{ + my ($w) = @_; + while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) + { + } + $w; +} + +# end of Tk::updateWidgets +1; diff --git a/Master/xemtex/perl/site/lib/auto/Win32/API/API.dll b/Master/xemtex/perl/site/lib/auto/Win32/API/API.dll Binary files differnew file mode 100644 index 00000000000..4c478dc3136 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/Win32/API/API.dll diff --git a/Master/xemtex/perl/site/lib/auto/XML/Parser/Expat/Expat.dll b/Master/xemtex/perl/site/lib/auto/XML/Parser/Expat/Expat.dll Binary files differnew file mode 100644 index 00000000000..be327d38a47 --- /dev/null +++ b/Master/xemtex/perl/site/lib/auto/XML/Parser/Expat/Expat.dll |