summaryrefslogtreecommitdiff
path: root/Master/xemtex/perl/site
diff options
context:
space:
mode:
Diffstat (limited to 'Master/xemtex/perl/site')
-rw-r--r--Master/xemtex/perl/site/lib/Tk.pm696
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Adjuster.pm435
-rw-r--r--Master/xemtex/perl/site/lib/Tk/After.pm88
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Bitmap.pm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Button.pm148
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Camel.xpm41
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Canvas.pm60
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Checkbutton.pm42
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Clipboard.pm110
-rw-r--r--Master/xemtex/perl/site/lib/Tk/CmdLine.pm954
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ColorEdit.xpm58
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ColorEditor.pm759
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Config.pm12
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Configure.pm69
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Derived.pm510
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Dialog.pm70
-rw-r--r--Master/xemtex/perl/site/lib/Tk/DialogBox.pm115
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Entry.pm517
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Event.pm13
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Event/IO.pm122
-rw-r--r--Master/xemtex/perl/site/lib/Tk/FBox.pm891
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Frame.pm373
-rw-r--r--Master/xemtex/perl/site/lib/Tk/IconList.pm536
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Image.pm73
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Label.pm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Listbox.pm856
-rw-r--r--Master/xemtex/perl/site/lib/Tk/MainWindow.pm188
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menu.pm1130
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menu/Item.pm180
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Menubutton.pm398
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Optionmenu.pm110
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Pixmap.pm19
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Pretty.pm93
-rw-r--r--Master/xemtex/perl/site/lib/Tk/ROText.pm36
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Radiobutton.pm45
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Scale.pm278
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Scrollbar.pm414
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Submethods.pm46
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Text.pm1600
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Text/Tag.pm46
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Tk.xbm44
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Tk.xpm41
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Toplevel.pm211
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Widget.pm1298
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Wm.pm165
-rw-r--r--Master/xemtex/perl/site/lib/Tk/X.pm398
-rw-r--r--Master/xemtex/perl/site/lib/Tk/X11/license.terms32
-rw-r--r--Master/xemtex/perl/site/lib/Tk/Xcamel.gifbin4193 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/act_folder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/act_folder.xpm22
-rw-r--r--Master/xemtex/perl/site/lib/Tk/anim.gifbin2533 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/balArrow.xbm4
-rw-r--r--Master/xemtex/perl/site/lib/Tk/cbxarrow.xbm6
-rw-r--r--Master/xemtex/perl/site/lib/Tk/file.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/file.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/folder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/folder.xpm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/icon.gifbin1924 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/license.terms35
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfile.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfolder.xbm5
-rw-r--r--Master/xemtex/perl/site/lib/Tk/openfolder.xpm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/prolog.ps284
-rw-r--r--Master/xemtex/perl/site/lib/Tk/srcfile.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/textfile.xpm18
-rw-r--r--Master/xemtex/perl/site/lib/Tk/tranicon.gifbin1718 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/Tk/widgets.pm21
-rw-r--r--Master/xemtex/perl/site/lib/Tk/win.xbm6
-rw-r--r--Master/xemtex/perl/site/lib/Tk/winfolder.xpm39
-rw-r--r--Master/xemtex/perl/site/lib/Tk/wintext.xpm42
-rw-r--r--Master/xemtex/perl/site/lib/Win32/API.pm719
-rw-r--r--Master/xemtex/perl/site/lib/Win32/API/Struct.pm528
-rw-r--r--Master/xemtex/perl/site/lib/Win32/API/Type.pm440
-rw-r--r--Master/xemtex/perl/site/lib/XML/Parser.pm1089
-rw-r--r--Master/xemtex/perl/site/lib/XML/Parser/Expat.pm1231
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Bitmap/Bitmap.dllbin6144 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Canvas/Canvas.dllbin139264 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix6
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Clipboard/getSelected.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/EnterFocus.al26
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Entry/Entry.dllbin23040 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Error.al20
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Event/Event.dllbin53248 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al21
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/FocusChildren.al35
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/FocusOK.al33
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/AddScrollbars.al52
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/FindMenu.al22
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/autosplit.ix24
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/freeze_on_map.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/label.al24
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/labelPack.al50
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/labelVariable.al27
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/packscrollbars.al86
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/queuePack.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/sbset.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Frame/scrollbars.al24
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/ImageNames.al13
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/ImageTypes.al13
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/AutoScan.al48
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginExtend.al29
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginSelect.al45
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginToggle.al39
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al16
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cancel.al43
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_End.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_Home.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/DataExtend.al39
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/ExtendUpDown.al30
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Listbox.dllbin20992 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al66
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/SelectAll.al31
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/SetList.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/UpDown.al39
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/autosplit.ix42
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/clipboardPaste.al21
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/deleteSelected.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/getSelected.al22
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Listbox/xyIndex.al27
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Menubutton/Menubutton.dllbin14848 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dllbin19968 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Receive.al23
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/RepeatId.al16
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Activate.al33
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonDown.al40
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonUp.al16
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/ControlPress.al31
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Drag.al29
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/EndDrag.al23
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Enter.al19
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Increment.al61
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Leave.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/Scale.dllbin20992 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix22
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonDown.al55
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonUp.al26
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Drag.al44
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/EndDrag.al29
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Enter.al21
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Leave.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Motion.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al38
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al37
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al35
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al32
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Scrollbar.dllbin15872 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al59
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/StartDrag.al33
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/autosplit.ix30
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Selection.al18
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Text/Text.dllbin94208 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix3
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Tk.dllbin573440 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindIn.al19
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindOut.al20
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Create.al56
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Destroy.al29
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_In.al24
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Out.al32
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Toplevel/autosplit.ix10
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/TraverseToMenu.al27
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Widget/ASkludge.al30
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Widget/autosplit.ix10
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Widget/clipboardKeysyms.al51
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Widget/pathname.al15
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/AnchorAdjust.al17
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/FullScreen.al29
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/Popup.al45
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/Post.al20
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/autosplit.ix14
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/Wm/iconposition.al24
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/X/X.dllbin19968 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix3
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/autosplit.ix43
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/break.al13
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/focusFollowsMouse.al14
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/focusNext.al45
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/focusPrev.al65
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/interps.al14
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/lsearch.al19
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/tabFocus.al13
-rw-r--r--Master/xemtex/perl/site/lib/auto/Tk/updateWidgets.al17
-rw-r--r--Master/xemtex/perl/site/lib/auto/Win32/API/API.dllbin20480 -> 0 bytes
-rw-r--r--Master/xemtex/perl/site/lib/auto/XML/Parser/Expat/Expat.dllbin163840 -> 0 bytes
186 files changed, 0 insertions, 21666 deletions
diff --git a/Master/xemtex/perl/site/lib/Tk.pm b/Master/xemtex/perl/site/lib/Tk.pm
deleted file mode 100644
index db05463d66d..00000000000
--- a/Master/xemtex/perl/site/lib/Tk.pm
+++ /dev/null
@@ -1,696 +0,0 @@
-#
-# 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
deleted file mode 100644
index 0fd5b4f765a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Adjuster.pm
+++ /dev/null
@@ -1,435 +0,0 @@
-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
deleted file mode 100644
index e5eac8b20a8..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/After.pm
+++ /dev/null
@@ -1,88 +0,0 @@
-# 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
deleted file mode 100644
index da563ffa6cb..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Bitmap.pm
+++ /dev/null
@@ -1,18 +0,0 @@
-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
deleted file mode 100644
index b0983ead7c3..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Button.pm
+++ /dev/null
@@ -1,148 +0,0 @@
-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
deleted file mode 100644
index ba33c0149ec..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Camel.xpm
+++ /dev/null
@@ -1,41 +0,0 @@
-/* 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
deleted file mode 100644
index e1ce78b6a93..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Canvas.pm
+++ /dev/null
@@ -1,60 +0,0 @@
-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
deleted file mode 100644
index e5c43f15f24..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Checkbutton.pm
+++ /dev/null
@@ -1,42 +0,0 @@
-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
deleted file mode 100644
index 6990b371f58..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Clipboard.pm
+++ /dev/null
@@ -1,110 +0,0 @@
-# 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
deleted file mode 100644
index 09d4da9c41d..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/CmdLine.pm
+++ /dev/null
@@ -1,954 +0,0 @@
-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
deleted file mode 100644
index ef3474cd869..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/ColorEdit.xpm
+++ /dev/null
@@ -1,58 +0,0 @@
-/* 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
deleted file mode 100644
index be4c373194a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/ColorEditor.pm
+++ /dev/null
@@ -1,759 +0,0 @@
-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
deleted file mode 100644
index 7c89d1aadb2..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Config.pm
+++ /dev/null
@@ -1,12 +0,0 @@
-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
deleted file mode 100644
index 5fc6e68ade6..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Configure.pm
+++ /dev/null
@@ -1,69 +0,0 @@
-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
deleted file mode 100644
index 89310d4d77a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Derived.pm
+++ /dev/null
@@ -1,510 +0,0 @@
-# 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
deleted file mode 100644
index e277e35af7b..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Dialog.pm
+++ /dev/null
@@ -1,70 +0,0 @@
-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
deleted file mode 100644
index 33b4b85ed85..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/DialogBox.pm
+++ /dev/null
@@ -1,115 +0,0 @@
-#
-# 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
deleted file mode 100644
index 2696b496497..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Entry.pm
+++ /dev/null
@@ -1,517 +0,0 @@
-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
deleted file mode 100644
index b162e475d4a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Event.pm
+++ /dev/null
@@ -1,13 +0,0 @@
-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
deleted file mode 100644
index a28ae54147a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Event/IO.pm
+++ /dev/null
@@ -1,122 +0,0 @@
-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
deleted file mode 100644
index bcc6ef1bf21..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/FBox.pm
+++ /dev/null
@@ -1,891 +0,0 @@
-# -*- 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
deleted file mode 100644
index b80937b8189..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Frame.pm
+++ /dev/null
@@ -1,373 +0,0 @@
-# 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
deleted file mode 100644
index 1c83e740887..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/IconList.pm
+++ /dev/null
@@ -1,536 +0,0 @@
-# -*- 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
deleted file mode 100644
index f6d6634c05b..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Image.pm
+++ /dev/null
@@ -1,73 +0,0 @@
-# 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
deleted file mode 100644
index e320e193846..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Label.pm
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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
deleted file mode 100644
index 0dd86c1ef2e..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Listbox.pm
+++ /dev/null
@@ -1,856 +0,0 @@
-# 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
deleted file mode 100644
index 2be63f90358..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/MainWindow.pm
+++ /dev/null
@@ -1,188 +0,0 @@
-# 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
deleted file mode 100644
index 409467e0e24..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Menu.pm
+++ /dev/null
@@ -1,1130 +0,0 @@
-# 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
deleted file mode 100644
index ab341ebaf84..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Menu/Item.pm
+++ /dev/null
@@ -1,180 +0,0 @@
-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
deleted file mode 100644
index ef9237900b2..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Menubutton.pm
+++ /dev/null
@@ -1,398 +0,0 @@
-# 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
deleted file mode 100644
index ca3f5dba22a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Optionmenu.pm
+++ /dev/null
@@ -1,110 +0,0 @@
-# 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
deleted file mode 100644
index 081b17f7892..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Pixmap.pm
+++ /dev/null
@@ -1,19 +0,0 @@
-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
deleted file mode 100644
index 409f1e1b320..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Pretty.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-# 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
deleted file mode 100644
index 96fa1e070d3..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/ROText.pm
+++ /dev/null
@@ -1,36 +0,0 @@
-# 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
deleted file mode 100644
index a706de6675e..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Radiobutton.pm
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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
deleted file mode 100644
index f31a68d9cb0..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Scale.pm
+++ /dev/null
@@ -1,278 +0,0 @@
-# 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
deleted file mode 100644
index a828682514f..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Scrollbar.pm
+++ /dev/null
@@ -1,414 +0,0 @@
-# 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
deleted file mode 100644
index 3c3abcea379..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Submethods.pm
+++ /dev/null
@@ -1,46 +0,0 @@
-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
deleted file mode 100644
index c4b4f162f77..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Text.pm
+++ /dev/null
@@ -1,1600 +0,0 @@
-# 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
deleted file mode 100644
index 7cddf48fd25..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Text/Tag.pm
+++ /dev/null
@@ -1,46 +0,0 @@
-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
deleted file mode 100644
index 136d4793037..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Tk.xbm
+++ /dev/null
@@ -1,44 +0,0 @@
-#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
deleted file mode 100644
index 7880a637f39..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Tk.xpm
+++ /dev/null
@@ -1,41 +0,0 @@
-/* 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
deleted file mode 100644
index 1d7533f8377..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Toplevel.pm
+++ /dev/null
@@ -1,211 +0,0 @@
-# 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
deleted file mode 100644
index 811d9e5e28b..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Widget.pm
+++ /dev/null
@@ -1,1298 +0,0 @@
-# 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
deleted file mode 100644
index a148987f350..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Wm.pm
+++ /dev/null
@@ -1,165 +0,0 @@
-# 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
deleted file mode 100644
index 856673d4bbe..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/X.pm
+++ /dev/null
@@ -1,398 +0,0 @@
-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
deleted file mode 100644
index 3dcd816f4a3..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/X11/license.terms
+++ /dev/null
@@ -1,32 +0,0 @@
-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
deleted file mode 100644
index cb88bc0afd8..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/Xcamel.gif
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/act_folder.xbm b/Master/xemtex/perl/site/lib/Tk/act_folder.xbm
deleted file mode 100644
index fc82949945b..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/act_folder.xbm
+++ /dev/null
@@ -1,5 +0,0 @@
-#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
deleted file mode 100644
index 0e7d682713a..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/act_folder.xpm
+++ /dev/null
@@ -1,22 +0,0 @@
-/* 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
deleted file mode 100644
index 96a50b701be..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/anim.gif
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/balArrow.xbm b/Master/xemtex/perl/site/lib/Tk/balArrow.xbm
deleted file mode 100644
index ee0664a4727..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/balArrow.xbm
+++ /dev/null
@@ -1,4 +0,0 @@
-#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
deleted file mode 100644
index ae4054488b9..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/cbxarrow.xbm
+++ /dev/null
@@ -1,6 +0,0 @@
-#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
deleted file mode 100644
index 7bf12bb4c9f..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/file.xbm
+++ /dev/null
@@ -1,5 +0,0 @@
-#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
deleted file mode 100644
index 10cc24f9a1e..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/file.xpm
+++ /dev/null
@@ -1,18 +0,0 @@
-/* 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
deleted file mode 100644
index 0398f0de777..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/folder.xbm
+++ /dev/null
@@ -1,5 +0,0 @@
-#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
deleted file mode 100644
index fda7c15a549..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/folder.xpm
+++ /dev/null
@@ -1,21 +0,0 @@
-/* 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
deleted file mode 100644
index dfe6b6621f2..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/icon.gif
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/license.terms b/Master/xemtex/perl/site/lib/Tk/license.terms
deleted file mode 100644
index 6a5d3728366..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/license.terms
+++ /dev/null
@@ -1,35 +0,0 @@
-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
deleted file mode 100644
index 859e2e57608..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/openfile.xbm
+++ /dev/null
@@ -1,5 +0,0 @@
-#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
deleted file mode 100644
index 59ee624efd0..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/openfolder.xbm
+++ /dev/null
@@ -1,5 +0,0 @@
-#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
deleted file mode 100644
index 191fe1e72bc..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/openfolder.xpm
+++ /dev/null
@@ -1,21 +0,0 @@
-/* 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
deleted file mode 100644
index 409e06a65a0..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/prolog.ps
+++ /dev/null
@@ -1,284 +0,0 @@
-%%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
deleted file mode 100644
index 06a40a96c84..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/srcfile.xpm
+++ /dev/null
@@ -1,18 +0,0 @@
-/* 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
deleted file mode 100644
index 8fa8d2f9032..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/textfile.xpm
+++ /dev/null
@@ -1,18 +0,0 @@
-/* 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
deleted file mode 100644
index dc7d494c572..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/tranicon.gif
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/Tk/widgets.pm b/Master/xemtex/perl/site/lib/Tk/widgets.pm
deleted file mode 100644
index 742866216cc..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/widgets.pm
+++ /dev/null
@@ -1,21 +0,0 @@
-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
deleted file mode 100644
index 13c05e8c2d7..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/win.xbm
+++ /dev/null
@@ -1,6 +0,0 @@
-#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
deleted file mode 100644
index 73fe734c6d0..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/winfolder.xpm
+++ /dev/null
@@ -1,39 +0,0 @@
-/* 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
deleted file mode 100644
index 50b2d5587dd..00000000000
--- a/Master/xemtex/perl/site/lib/Tk/wintext.xpm
+++ /dev/null
@@ -1,42 +0,0 @@
-/* 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
deleted file mode 100644
index 154de7a80ee..00000000000
--- a/Master/xemtex/perl/site/lib/Win32/API.pm
+++ /dev/null
@@ -1,719 +0,0 @@
-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
deleted file mode 100644
index acd160a95a8..00000000000
--- a/Master/xemtex/perl/site/lib/Win32/API/Struct.pm
+++ /dev/null
@@ -1,528 +0,0 @@
-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
deleted file mode 100644
index 9ebe9ff57dc..00000000000
--- a/Master/xemtex/perl/site/lib/Win32/API/Type.pm
+++ /dev/null
@@ -1,440 +0,0 @@
-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
deleted file mode 100644
index f150b615a2d..00000000000
--- a/Master/xemtex/perl/site/lib/XML/Parser.pm
+++ /dev/null
@@ -1,1089 +0,0 @@
-# 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
deleted file mode 100644
index 370f6f67bf6..00000000000
--- a/Master/xemtex/perl/site/lib/XML/Parser/Expat.pm
+++ /dev/null
@@ -1,1231 +0,0 @@
-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/\&/\&amp;/g;
- $text =~ s/</\&lt;/g;
- foreach (@_) {
- croak "xml_escape: '$_' isn't a single character" if length($_) > 1;
-
- if ($_ eq '>') {
- $text =~ s/>/\&gt;/g;
- }
- elsif ($_ eq '"') {
- $text =~ s/\"/\&quot;/;
- }
- elsif ($_ eq "'") {
- $text =~ s/\'/\&apos;/;
- }
- 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
deleted file mode 100644
index f6b75b704c5..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Bitmap/Bitmap.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al b/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al
deleted file mode 100644
index 82105140755..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/CancelRepeat.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index b6a1321a741..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Canvas/Canvas.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix
deleted file mode 100644
index 360e44863af..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/autosplit.ix
+++ /dev/null
@@ -1,6 +0,0 @@
-# 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
deleted file mode 100644
index 99d70ee5d76..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Clipboard/getSelected.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index 93cc88a8176..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/EnterFocus.al
+++ /dev/null
@@ -1,26 +0,0 @@
-# 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
deleted file mode 100644
index dd36353deef..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Entry/Entry.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Error.al b/Master/xemtex/perl/site/lib/auto/Tk/Error.al
deleted file mode 100644
index 4d4f06dc941..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Error.al
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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
deleted file mode 100644
index 2339002b71b..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Event/Event.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al b/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al
deleted file mode 100644
index c5e12b684e7..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/FirstMenu.al
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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
deleted file mode 100644
index f6d8f6af753..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/FocusChildren.al
+++ /dev/null
@@ -1,35 +0,0 @@
-# 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
deleted file mode 100644
index bffeffba8f4..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/FocusOK.al
+++ /dev/null
@@ -1,33 +0,0 @@
-# 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
deleted file mode 100644
index ef3b7537d6e..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/AddScrollbars.al
+++ /dev/null
@@ -1,52 +0,0 @@
-# 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
deleted file mode 100644
index b82a61da507..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/FindMenu.al
+++ /dev/null
@@ -1,22 +0,0 @@
-# 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
deleted file mode 100644
index 670cd9eb1c4..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/autosplit.ix
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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
deleted file mode 100644
index 61697e647fb..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/freeze_on_map.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 3196344c9b8..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/label.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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
deleted file mode 100644
index 1dd66963088..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelPack.al
+++ /dev/null
@@ -1,50 +0,0 @@
-# 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
deleted file mode 100644
index 6a068e32873..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/labelVariable.al
+++ /dev/null
@@ -1,27 +0,0 @@
-# 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
deleted file mode 100644
index 54c59d5bcf2..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/packscrollbars.al
+++ /dev/null
@@ -1,86 +0,0 @@
-# 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
deleted file mode 100644
index a8a24927d8c..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/queuePack.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 357fcfd4a4e..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/sbset.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index 2a4706eb198..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Frame/scrollbars.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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
deleted file mode 100644
index 2a4bd24818a..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/ImageNames.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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
deleted file mode 100644
index 0f9b8be674a..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/ImageTypes.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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
deleted file mode 100644
index e366618df81..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/AutoScan.al
+++ /dev/null
@@ -1,48 +0,0 @@
-# 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
deleted file mode 100644
index ad3fe4c6d33..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginExtend.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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
deleted file mode 100644
index b29359c70c5..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginSelect.al
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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
deleted file mode 100644
index 3f7ddff4cf9..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/BeginToggle.al
+++ /dev/null
@@ -1,39 +0,0 @@
-# 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
deleted file mode 100644
index 7461080092f..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al
+++ /dev/null
@@ -1,16 +0,0 @@
-# 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
deleted file mode 100644
index 3974c2e145c..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cancel.al
+++ /dev/null
@@ -1,43 +0,0 @@
-# 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
deleted file mode 100644
index de53c8048aa..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_End.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 34f09d21bb9..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_Home.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 382a68528a8..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index fdeb0368bba..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/DataExtend.al
+++ /dev/null
@@ -1,39 +0,0 @@
-# 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
deleted file mode 100644
index 9c21c0a93a1..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/ExtendUpDown.al
+++ /dev/null
@@ -1,30 +0,0 @@
-# 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
deleted file mode 100644
index de4907125a9..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Listbox.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al b/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al
deleted file mode 100644
index d67ec8121d9..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/Motion.al
+++ /dev/null
@@ -1,66 +0,0 @@
-# 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
deleted file mode 100644
index 319ce5c2a9c..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SelectAll.al
+++ /dev/null
@@ -1,31 +0,0 @@
-# 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
deleted file mode 100644
index 5f4ba81ddf3..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/SetList.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index e2ce7edce78..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/UpDown.al
+++ /dev/null
@@ -1,39 +0,0 @@
-# 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
deleted file mode 100644
index 5846f38c4ce..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/autosplit.ix
+++ /dev/null
@@ -1,42 +0,0 @@
-# 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
deleted file mode 100644
index 7deae1e75a4..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/clipboardPaste.al
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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
deleted file mode 100644
index 6fc89af9e91..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/deleteSelected.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 64706cfa9b4..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/getSelected.al
+++ /dev/null
@@ -1,22 +0,0 @@
-# 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
deleted file mode 100644
index bfd364a7f9b..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Listbox/xyIndex.al
+++ /dev/null
@@ -1,27 +0,0 @@
-# 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
deleted file mode 100644
index f05f347cc8b..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Menubutton/Menubutton.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll b/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll
deleted file mode 100644
index 0e887aaefc3..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Pixmap/Pixmap.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Receive.al b/Master/xemtex/perl/site/lib/auto/Tk/Receive.al
deleted file mode 100644
index e33b6bdc1af..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Receive.al
+++ /dev/null
@@ -1,23 +0,0 @@
-# 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
deleted file mode 100644
index 06728f02221..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/RepeatId.al
+++ /dev/null
@@ -1,16 +0,0 @@
-# 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
deleted file mode 100644
index 500358c8e0e..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Activate.al
+++ /dev/null
@@ -1,33 +0,0 @@
-# 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
deleted file mode 100644
index 61ed6f32c11..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonDown.al
+++ /dev/null
@@ -1,40 +0,0 @@
-# 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
deleted file mode 100644
index d5a22a77a46..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ButtonUp.al
+++ /dev/null
@@ -1,16 +0,0 @@
-# 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
deleted file mode 100644
index 50d7ad8b447..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/ControlPress.al
+++ /dev/null
@@ -1,31 +0,0 @@
-# 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
deleted file mode 100644
index 0bc63b12879..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Drag.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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
deleted file mode 100644
index 86037b86d92..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/EndDrag.al
+++ /dev/null
@@ -1,23 +0,0 @@
-# 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
deleted file mode 100644
index 1326a5ed9a0..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Enter.al
+++ /dev/null
@@ -1,19 +0,0 @@
-# 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
deleted file mode 100644
index 76432eeaf40..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Increment.al
+++ /dev/null
@@ -1,61 +0,0 @@
-# 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
deleted file mode 100644
index eb6f7b69f89..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Leave.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index ff1568bcfe6..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/Scale.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix
deleted file mode 100644
index a5c5d2292f2..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scale/autosplit.ix
+++ /dev/null
@@ -1,22 +0,0 @@
-# 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
deleted file mode 100644
index c17199b73b6..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonDown.al
+++ /dev/null
@@ -1,55 +0,0 @@
-# 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
deleted file mode 100644
index 24058d857ec..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ButtonUp.al
+++ /dev/null
@@ -1,26 +0,0 @@
-# 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
deleted file mode 100644
index 40d6b0f8d1b..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Drag.al
+++ /dev/null
@@ -1,44 +0,0 @@
-# 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
deleted file mode 100644
index 5b1fc837326..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/EndDrag.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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
deleted file mode 100644
index 45a21f920e5..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Enter.al
+++ /dev/null
@@ -1,21 +0,0 @@
-# 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
deleted file mode 100644
index 349911e304e..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Leave.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 0b414efa389..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Motion.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index bd3d29afa77..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al
+++ /dev/null
@@ -1,38 +0,0 @@
-# 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
deleted file mode 100644
index 99e84e394c5..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al
+++ /dev/null
@@ -1,37 +0,0 @@
-# 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
deleted file mode 100644
index c3a25af3c19..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al
+++ /dev/null
@@ -1,35 +0,0 @@
-# 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
deleted file mode 100644
index 71be23e6794..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al
+++ /dev/null
@@ -1,32 +0,0 @@
-# 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
deleted file mode 100644
index 81eec672093..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al b/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al
deleted file mode 100644
index 21a743bf7fd..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/Select.al
+++ /dev/null
@@ -1,59 +0,0 @@
-# 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
deleted file mode 100644
index d544dc53945..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/StartDrag.al
+++ /dev/null
@@ -1,33 +0,0 @@
-# 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
deleted file mode 100644
index 293d1322dd4..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Scrollbar/autosplit.ix
+++ /dev/null
@@ -1,30 +0,0 @@
-# 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
deleted file mode 100644
index 0d50a9f31df..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Selection.al
+++ /dev/null
@@ -1,18 +0,0 @@
-# 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
deleted file mode 100644
index 8cb98c8a455..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Text/Text.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix
deleted file mode 100644
index 48a5455c34a..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Text/autosplit.ix
+++ /dev/null
@@ -1,3 +0,0 @@
-# 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
deleted file mode 100644
index ee55846fdcb..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Tk.dll
+++ /dev/null
Binary files differ
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
deleted file mode 100644
index cc2ceaf7b63..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindIn.al
+++ /dev/null
@@ -1,19 +0,0 @@
-# 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
deleted file mode 100644
index 5c5cf9cc3de..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_BindOut.al
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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
deleted file mode 100644
index 0953c045be8..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Create.al
+++ /dev/null
@@ -1,56 +0,0 @@
-# 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
deleted file mode 100644
index e20f1eb7568..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Destroy.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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
deleted file mode 100644
index a4b5c67a155..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_In.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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
deleted file mode 100644
index 96a3841e6fd..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/FG_Out.al
+++ /dev/null
@@ -1,32 +0,0 @@
-# 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
deleted file mode 100644
index 6267c58604c..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Toplevel/autosplit.ix
+++ /dev/null
@@ -1,10 +0,0 @@
-# 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
deleted file mode 100644
index 03b814a1334..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/TraverseToMenu.al
+++ /dev/null
@@ -1,27 +0,0 @@
-# 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
deleted file mode 100644
index fe9b23df886..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Widget/ASkludge.al
+++ /dev/null
@@ -1,30 +0,0 @@
-# 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
deleted file mode 100644
index f0a7ffb9891..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Widget/autosplit.ix
+++ /dev/null
@@ -1,10 +0,0 @@
-# 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
deleted file mode 100644
index 71996befb5f..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Widget/clipboardKeysyms.al
+++ /dev/null
@@ -1,51 +0,0 @@
-# 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
deleted file mode 100644
index e22439a73cd..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Widget/pathname.al
+++ /dev/null
@@ -1,15 +0,0 @@
-# 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
deleted file mode 100644
index a699cee6920..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/AnchorAdjust.al
+++ /dev/null
@@ -1,17 +0,0 @@
-# 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
deleted file mode 100644
index 83ab7a3241c..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/FullScreen.al
+++ /dev/null
@@ -1,29 +0,0 @@
-# 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
deleted file mode 100644
index 59a6f496d53..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/Popup.al
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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
deleted file mode 100644
index 277981329b0..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/Post.al
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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
deleted file mode 100644
index 54b764985de..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/autosplit.ix
+++ /dev/null
@@ -1,14 +0,0 @@
-# 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
deleted file mode 100644
index 6a5b0ec92d8..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/Wm/iconposition.al
+++ /dev/null
@@ -1,24 +0,0 @@
-# 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
deleted file mode 100644
index 81c220688ae..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/X/X.dll
+++ /dev/null
Binary files differ
diff --git a/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix b/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix
deleted file mode 100644
index e63dbf19b00..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/X/autosplit.ix
+++ /dev/null
@@ -1,3 +0,0 @@
-# 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
deleted file mode 100644
index 8e8d2880a02..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/autosplit.ix
+++ /dev/null
@@ -1,43 +0,0 @@
-# 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
deleted file mode 100644
index 388cd46b21b..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/break.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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
deleted file mode 100644
index 697e8c61fae..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/focusFollowsMouse.al
+++ /dev/null
@@ -1,14 +0,0 @@
-# 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
deleted file mode 100644
index b5dbc9bc7d6..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/focusNext.al
+++ /dev/null
@@ -1,45 +0,0 @@
-# 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
deleted file mode 100644
index 77aadf1b929..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/focusPrev.al
+++ /dev/null
@@ -1,65 +0,0 @@
-# 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
deleted file mode 100644
index fe01aa3099f..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/interps.al
+++ /dev/null
@@ -1,14 +0,0 @@
-# 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
deleted file mode 100644
index 7a597051bec..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/lsearch.al
+++ /dev/null
@@ -1,19 +0,0 @@
-# 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
deleted file mode 100644
index 4016abff331..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/tabFocus.al
+++ /dev/null
@@ -1,13 +0,0 @@
-# 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
deleted file mode 100644
index 0fec5abb3c8..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Tk/updateWidgets.al
+++ /dev/null
@@ -1,17 +0,0 @@
-# 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
deleted file mode 100644
index 4c478dc3136..00000000000
--- a/Master/xemtex/perl/site/lib/auto/Win32/API/API.dll
+++ /dev/null
Binary files differ
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
deleted file mode 100644
index be327d38a47..00000000000
--- a/Master/xemtex/perl/site/lib/auto/XML/Parser/Expat/Expat.dll
+++ /dev/null
Binary files differ