diff options
Diffstat (limited to 'Master/perltl/site')
186 files changed, 0 insertions, 21666 deletions
diff --git a/Master/perltl/site/lib/Tk.pm b/Master/perltl/site/lib/Tk.pm deleted file mode 100644 index db05463d66d..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Adjuster.pm b/Master/perltl/site/lib/Tk/Adjuster.pm deleted file mode 100644 index 0fd5b4f765a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/After.pm b/Master/perltl/site/lib/Tk/After.pm deleted file mode 100644 index e5eac8b20a8..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Bitmap.pm b/Master/perltl/site/lib/Tk/Bitmap.pm deleted file mode 100644 index da563ffa6cb..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Button.pm b/Master/perltl/site/lib/Tk/Button.pm deleted file mode 100644 index b0983ead7c3..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Camel.xpm b/Master/perltl/site/lib/Tk/Camel.xpm deleted file mode 100644 index ba33c0149ec..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Canvas.pm b/Master/perltl/site/lib/Tk/Canvas.pm deleted file mode 100644 index e1ce78b6a93..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Checkbutton.pm b/Master/perltl/site/lib/Tk/Checkbutton.pm deleted file mode 100644 index e5c43f15f24..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Clipboard.pm b/Master/perltl/site/lib/Tk/Clipboard.pm deleted file mode 100644 index 6990b371f58..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/CmdLine.pm b/Master/perltl/site/lib/Tk/CmdLine.pm deleted file mode 100644 index 09d4da9c41d..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/ColorEdit.xpm b/Master/perltl/site/lib/Tk/ColorEdit.xpm deleted file mode 100644 index ef3474cd869..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/ColorEditor.pm b/Master/perltl/site/lib/Tk/ColorEditor.pm deleted file mode 100644 index be4c373194a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Config.pm b/Master/perltl/site/lib/Tk/Config.pm deleted file mode 100644 index 7c89d1aadb2..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Configure.pm b/Master/perltl/site/lib/Tk/Configure.pm deleted file mode 100644 index 5fc6e68ade6..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Derived.pm b/Master/perltl/site/lib/Tk/Derived.pm deleted file mode 100644 index 89310d4d77a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Dialog.pm b/Master/perltl/site/lib/Tk/Dialog.pm deleted file mode 100644 index e277e35af7b..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/DialogBox.pm b/Master/perltl/site/lib/Tk/DialogBox.pm deleted file mode 100644 index 33b4b85ed85..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Entry.pm b/Master/perltl/site/lib/Tk/Entry.pm deleted file mode 100644 index 2696b496497..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Event.pm b/Master/perltl/site/lib/Tk/Event.pm deleted file mode 100644 index b162e475d4a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Event/IO.pm b/Master/perltl/site/lib/Tk/Event/IO.pm deleted file mode 100644 index a28ae54147a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/FBox.pm b/Master/perltl/site/lib/Tk/FBox.pm deleted file mode 100644 index bcc6ef1bf21..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Frame.pm b/Master/perltl/site/lib/Tk/Frame.pm deleted file mode 100644 index b80937b8189..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/IconList.pm b/Master/perltl/site/lib/Tk/IconList.pm deleted file mode 100644 index 1c83e740887..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Image.pm b/Master/perltl/site/lib/Tk/Image.pm deleted file mode 100644 index f6d6634c05b..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Label.pm b/Master/perltl/site/lib/Tk/Label.pm deleted file mode 100644 index e320e193846..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Listbox.pm b/Master/perltl/site/lib/Tk/Listbox.pm deleted file mode 100644 index 0dd86c1ef2e..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/MainWindow.pm b/Master/perltl/site/lib/Tk/MainWindow.pm deleted file mode 100644 index 2be63f90358..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Menu.pm b/Master/perltl/site/lib/Tk/Menu.pm deleted file mode 100644 index 409467e0e24..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Menu/Item.pm b/Master/perltl/site/lib/Tk/Menu/Item.pm deleted file mode 100644 index ab341ebaf84..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Menubutton.pm b/Master/perltl/site/lib/Tk/Menubutton.pm deleted file mode 100644 index ef9237900b2..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Optionmenu.pm b/Master/perltl/site/lib/Tk/Optionmenu.pm deleted file mode 100644 index ca3f5dba22a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Pixmap.pm b/Master/perltl/site/lib/Tk/Pixmap.pm deleted file mode 100644 index 081b17f7892..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Pretty.pm b/Master/perltl/site/lib/Tk/Pretty.pm deleted file mode 100644 index 409f1e1b320..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/ROText.pm b/Master/perltl/site/lib/Tk/ROText.pm deleted file mode 100644 index 96fa1e070d3..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Radiobutton.pm b/Master/perltl/site/lib/Tk/Radiobutton.pm deleted file mode 100644 index a706de6675e..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Scale.pm b/Master/perltl/site/lib/Tk/Scale.pm deleted file mode 100644 index f31a68d9cb0..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Scrollbar.pm b/Master/perltl/site/lib/Tk/Scrollbar.pm deleted file mode 100644 index a828682514f..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Submethods.pm b/Master/perltl/site/lib/Tk/Submethods.pm deleted file mode 100644 index 3c3abcea379..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Text.pm b/Master/perltl/site/lib/Tk/Text.pm deleted file mode 100644 index c4b4f162f77..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Text/Tag.pm b/Master/perltl/site/lib/Tk/Text/Tag.pm deleted file mode 100644 index 7cddf48fd25..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Tk.xbm b/Master/perltl/site/lib/Tk/Tk.xbm deleted file mode 100644 index 136d4793037..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Tk.xpm b/Master/perltl/site/lib/Tk/Tk.xpm deleted file mode 100644 index 7880a637f39..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Toplevel.pm b/Master/perltl/site/lib/Tk/Toplevel.pm deleted file mode 100644 index 1d7533f8377..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Widget.pm b/Master/perltl/site/lib/Tk/Widget.pm deleted file mode 100644 index 811d9e5e28b..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Wm.pm b/Master/perltl/site/lib/Tk/Wm.pm deleted file mode 100644 index a148987f350..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/X.pm b/Master/perltl/site/lib/Tk/X.pm deleted file mode 100644 index 856673d4bbe..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/X11/license.terms b/Master/perltl/site/lib/Tk/X11/license.terms deleted file mode 100644 index 3dcd816f4a3..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/Xcamel.gif b/Master/perltl/site/lib/Tk/Xcamel.gif Binary files differdeleted file mode 100644 index cb88bc0afd8..00000000000 --- a/Master/perltl/site/lib/Tk/Xcamel.gif +++ /dev/null diff --git a/Master/perltl/site/lib/Tk/act_folder.xbm b/Master/perltl/site/lib/Tk/act_folder.xbm deleted file mode 100644 index fc82949945b..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/act_folder.xpm b/Master/perltl/site/lib/Tk/act_folder.xpm deleted file mode 100644 index 0e7d682713a..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/anim.gif b/Master/perltl/site/lib/Tk/anim.gif Binary files differdeleted file mode 100644 index 96a50b701be..00000000000 --- a/Master/perltl/site/lib/Tk/anim.gif +++ /dev/null diff --git a/Master/perltl/site/lib/Tk/balArrow.xbm b/Master/perltl/site/lib/Tk/balArrow.xbm deleted file mode 100644 index ee0664a4727..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/cbxarrow.xbm b/Master/perltl/site/lib/Tk/cbxarrow.xbm deleted file mode 100644 index ae4054488b9..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/file.xbm b/Master/perltl/site/lib/Tk/file.xbm deleted file mode 100644 index 7bf12bb4c9f..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/file.xpm b/Master/perltl/site/lib/Tk/file.xpm deleted file mode 100644 index 10cc24f9a1e..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/folder.xbm b/Master/perltl/site/lib/Tk/folder.xbm deleted file mode 100644 index 0398f0de777..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/folder.xpm b/Master/perltl/site/lib/Tk/folder.xpm deleted file mode 100644 index fda7c15a549..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/icon.gif b/Master/perltl/site/lib/Tk/icon.gif Binary files differdeleted file mode 100644 index dfe6b6621f2..00000000000 --- a/Master/perltl/site/lib/Tk/icon.gif +++ /dev/null diff --git a/Master/perltl/site/lib/Tk/license.terms b/Master/perltl/site/lib/Tk/license.terms deleted file mode 100644 index 6a5d3728366..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/openfile.xbm b/Master/perltl/site/lib/Tk/openfile.xbm deleted file mode 100644 index 859e2e57608..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/openfolder.xbm b/Master/perltl/site/lib/Tk/openfolder.xbm deleted file mode 100644 index 59ee624efd0..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/openfolder.xpm b/Master/perltl/site/lib/Tk/openfolder.xpm deleted file mode 100644 index 191fe1e72bc..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/prolog.ps b/Master/perltl/site/lib/Tk/prolog.ps deleted file mode 100644 index 409e06a65a0..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/srcfile.xpm b/Master/perltl/site/lib/Tk/srcfile.xpm deleted file mode 100644 index 06a40a96c84..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/textfile.xpm b/Master/perltl/site/lib/Tk/textfile.xpm deleted file mode 100644 index 8fa8d2f9032..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/tranicon.gif b/Master/perltl/site/lib/Tk/tranicon.gif Binary files differdeleted file mode 100644 index dc7d494c572..00000000000 --- a/Master/perltl/site/lib/Tk/tranicon.gif +++ /dev/null diff --git a/Master/perltl/site/lib/Tk/widgets.pm b/Master/perltl/site/lib/Tk/widgets.pm deleted file mode 100644 index 742866216cc..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/win.xbm b/Master/perltl/site/lib/Tk/win.xbm deleted file mode 100644 index 13c05e8c2d7..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/winfolder.xpm b/Master/perltl/site/lib/Tk/winfolder.xpm deleted file mode 100644 index 73fe734c6d0..00000000000 --- a/Master/perltl/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/perltl/site/lib/Tk/wintext.xpm b/Master/perltl/site/lib/Tk/wintext.xpm deleted file mode 100644 index 50b2d5587dd..00000000000 --- a/Master/perltl/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/perltl/site/lib/Win32/API.pm b/Master/perltl/site/lib/Win32/API.pm deleted file mode 100644 index 154de7a80ee..00000000000 --- a/Master/perltl/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/perltl/site/lib/Win32/API/Struct.pm b/Master/perltl/site/lib/Win32/API/Struct.pm deleted file mode 100644 index acd160a95a8..00000000000 --- a/Master/perltl/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/perltl/site/lib/Win32/API/Type.pm b/Master/perltl/site/lib/Win32/API/Type.pm deleted file mode 100644 index 9ebe9ff57dc..00000000000 --- a/Master/perltl/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/perltl/site/lib/XML/Parser.pm b/Master/perltl/site/lib/XML/Parser.pm deleted file mode 100644 index f150b615a2d..00000000000 --- a/Master/perltl/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/perltl/site/lib/XML/Parser/Expat.pm b/Master/perltl/site/lib/XML/Parser/Expat.pm deleted file mode 100644 index 370f6f67bf6..00000000000 --- a/Master/perltl/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/\&/\&/g; - $text =~ s/</\</g; - foreach (@_) { - croak "xml_escape: '$_' isn't a single character" if length($_) > 1; - - if ($_ eq '>') { - $text =~ s/>/\>/g; - } - elsif ($_ eq '"') { - $text =~ s/\"/\"/; - } - elsif ($_ eq "'") { - $text =~ s/\'/\'/; - } - else { - my $rep = '&#' . sprintf('x%X', ord($_)) . ';'; - if (/\W/) { - my $ptrn = "\\$_"; - $text =~ s/$ptrn/$rep/g; - } - else { - $text =~ s/$_/$rep/g; - } - } - } - $text; -} - -sub skip_until { - my $self = shift; - if ($self->{_State_} <= 1) { - SkipUntil($self->{Parser}, $_[0]); - } -} - -sub release { - my $self = shift; - ParserRelease($self->{Parser}); -} - -sub DESTROY { - my $self = shift; - ParserFree($self->{Parser}); -} - -sub parse { - my $self = shift; - my $arg = shift; - croak "Parse already in progress (Expat)" if $self->{_State_}; - $self->{_State_} = 1; - my $parser = $self->{Parser}; - my $ioref; - my $result = 0; - - if (defined $arg) { - if (ref($arg) and UNIVERSAL::isa($arg, 'IO::Handle')) { - $ioref = $arg; - } elsif (tied($arg)) { - my $class = ref($arg); - no strict 'refs'; - $ioref = $arg if defined &{"${class}::TIEHANDLE"}; - } - else { - eval { - $ioref = *{$arg}{IO}; - }; - undef $@; - } - } - - if (defined($ioref)) { - my $delim = $self->{Stream_Delimiter}; - my $prev_rs; - - $prev_rs = ref($ioref)->input_record_separator("\n$delim\n") - if defined($delim); - - $result = ParseStream($parser, $ioref, $delim); - - ref($ioref)->input_record_separator($prev_rs) - if defined($delim); - } else { - $result = ParseString($parser, $arg); - } - - $self->{_State_} = 2; - $result or croak $self->{ErrorMessage}; -} - -sub parsestring { - my $self = shift; - $self->parse(@_); -} - -sub parsefile { - my $self = shift; - croak "Parser has already been used" if $self->{_State_}; - local(*FILE); - open(FILE, $_[0]) or croak "Couldn't open $_[0]:\n$!"; - binmode(FILE); - my $ret = $self->parse(*FILE); - close(FILE); - $ret; -} - -################################################################ -package XML::Parser::ContentModel; -use overload '""' => \&asString, 'eq' => \&thiseq; - -sub EMPTY () {1} -sub ANY () {2} -sub MIXED () {3} -sub NAME () {4} -sub CHOICE () {5} -sub SEQ () {6} - - -sub isempty { - return $_[0]->{Type} == EMPTY; -} - -sub isany { - return $_[0]->{Type} == ANY; -} - -sub ismixed { - return $_[0]->{Type} == MIXED; -} - -sub isname { - return $_[0]->{Type} == NAME; -} - -sub name { - return $_[0]->{Tag}; -} - -sub ischoice { - return $_[0]->{Type} == CHOICE; -} - -sub isseq { - return $_[0]->{Type} == SEQ; -} - -sub quant { - return $_[0]->{Quant}; -} - -sub children { - my $children = $_[0]->{Children}; - if (defined $children) { - return @$children; - } - return undef; -} - -sub asString { - my ($self) = @_; - my $ret; - - if ($self->{Type} == NAME) { - $ret = $self->{Tag}; - } - elsif ($self->{Type} == EMPTY) { - return "EMPTY"; - } - elsif ($self->{Type} == ANY) { - return "ANY"; - } - elsif ($self->{Type} == MIXED) { - $ret = '(#PCDATA'; - foreach (@{$self->{Children}}) { - $ret .= '|' . $_; - } - $ret .= ')'; - } - else { - my $sep = $self->{Type} == CHOICE ? '|' : ','; - my @children_str = map { $_->asString } @{$self->{Children}}; - $ret = '(' . join($sep, @children_str) . ')'; - } - - $ret .= $self->{Quant} if $self->{Quant}; - return $ret; -} - -sub thiseq { - my $self = shift; - - return $self->asString eq $_[0]; -} - -################################################################ -package XML::Parser::ExpatNB; - -use vars qw(@ISA); -use Carp; - -@ISA = qw(XML::Parser::Expat); - -sub parse { - my $self = shift; - my $class = ref($self); - croak "parse method not supported in $class"; -} - -sub parsestring { - my $self = shift; - my $class = ref($self); - croak "parsestring method not supported in $class"; -} - -sub parsefile { - my $self = shift; - my $class = ref($self); - croak "parsefile method not supported in $class"; -} - -sub parse_more { - my ($self, $data) = @_; - - $self->{_State_} = 1; - my $ret = XML::Parser::Expat::ParsePartial($self->{Parser}, $data); - - croak $self->{ErrorMessage} unless $ret; -} - -sub parse_done { - my $self = shift; - - my $ret = XML::Parser::Expat::ParseDone($self->{Parser}); - unless ($ret) { - my $msg = $self->{ErrorMessage}; - $self->release; - croak $msg; - } - - $self->{_State_} = 2; - - my $result = $ret; - my @result = (); - my $final = $self->{FinalHandler}; - if (defined $final) { - if (wantarray) { - @result = &$final($self); - } - else { - $result = &$final($self); - } - } - - $self->release; - - return unless defined wantarray; - return wantarray ? @result : $result; -} - -################################################################ - -package XML::Parser::Encinfo; - -sub DESTROY { - my $self = shift; - XML::Parser::Expat::FreeEncoding($self); -} - -1; - -__END__ - -=head1 NAME - -XML::Parser::Expat - Lowlevel access to James Clark's expat XML parser - -=head1 SYNOPSIS - - use XML::Parser::Expat; - - $parser = new XML::Parser::Expat; - $parser->setHandlers('Start' => \&sh, - 'End' => \&eh, - 'Char' => \&ch); - open(FOO, 'info.xml') or die "Couldn't open"; - $parser->parse(*FOO); - close(FOO); - # $parser->parse('<foo id="me"> here <em>we</em> go </foo>'); - - sub sh - { - my ($p, $el, %atts) = @_; - $p->setHandlers('Char' => \&spec) - if ($el eq 'special'); - ... - } - - sub eh - { - my ($p, $el) = @_; - $p->setHandlers('Char' => \&ch) # Special elements won't contain - if ($el eq 'special'); # other special elements - ... - } - -=head1 DESCRIPTION - -This module provides an interface to James Clark's XML parser, expat. As in -expat, a single instance of the parser can only parse one document. Calls -to parsestring after the first for a given instance will die. - -Expat (and XML::Parser::Expat) are event based. As the parser recognizes -parts of the document (say the start or end of an XML element), then any -handlers registered for that type of an event are called with suitable -parameters. - -=head1 METHODS - -=over 4 - -=item new - -This is a class method, the constructor for XML::Parser::Expat. Options are -passed as keyword value pairs. The recognized options are: - -=over 4 - -=item * ProtocolEncoding - -The protocol encoding name. The default is none. The expat built-in -encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and C<US-ASCII>. -Other encodings may be used if they have encoding maps in one of the -directories in the @Encoding_Path list. Setting the protocol encoding -overrides any encoding in the XML declaration. - -=item * Namespaces - -When this option is given with a true value, then the parser does namespace -processing. By default, namespace processing is turned off. When it is -turned on, the parser consumes I<xmlns> attributes and strips off prefixes -from element and attributes names where those prefixes have a defined -namespace. A name's namespace can be found using the L<"namespace"> method -and two names can be checked for absolute equality with the L<"eq_name"> -method. - -=item * NoExpand - -Normally, the parser will try to expand references to entities defined in -the internal subset. If this option is set to a true value, and a default -handler is also set, then the default handler will be called when an -entity reference is seen in text. This has no effect if a default handler -has not been registered, and it has no effect on the expansion of entity -references inside attribute values. - -=item * Stream_Delimiter - -This option takes a string value. When this string is found alone on a line -while parsing from a stream, then the parse is ended as if it saw an end of -file. The intended use is with a stream of xml documents in a MIME multipart -format. The string should not contain a trailing newline. - -=item * ErrorContext - -When this option is defined, errors are reported in context. The value -of ErrorContext should be the number of lines to show on either side of -the line in which the error occurred. - -=item * ParseParamEnt - -Unless standalone is set to "yes" in the XML declaration, setting this to -a true value allows the external DTD to be read, and parameter entities -to be parsed and expanded. - -=item * Base - -The base to use for relative pathnames or URLs. This can also be done by -using the base method. - -=back - -=item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]]) - -This method registers handlers for the various events. If no handlers are -registered, then a call to parsestring or parsefile will only determine if -the corresponding XML document is well formed (by returning without error.) -This may be called from within a handler, after the parse has started. - -Setting a handler to something that evaluates to false unsets that -handler. - -This method returns a list of type, handler pairs corresponding to the -input. The handlers returned are the ones that were in effect before the -call to setHandlers. - -The recognized events and the parameters passed to the corresponding -handlers are: - -=over 4 - -=item * Start (Parser, Element [, Attr, Val [,...]]) - -This event is generated when an XML start tag is recognized. Parser is -an XML::Parser::Expat instance. Element is the name of the XML element that -is opened with the start tag. The Attr & Val pairs are generated for each -attribute in the start tag. - -=item * End (Parser, Element) - -This event is generated when an XML end tag is recognized. Note that -an XML empty tag (<foo/>) generates both a start and an end event. - -There is always a lower level start and end handler installed that wrap -the corresponding callbacks. This is to handle the context mechanism. -A consequence of this is that the default handler (see below) will not -see a start tag or end tag unless the default_current method is called. - -=item * Char (Parser, String) - -This event is generated when non-markup is recognized. The non-markup -sequence of characters is in String. A single non-markup sequence of -characters may generate multiple calls to this handler. Whatever the -encoding of the string in the original document, this is given to the -handler in UTF-8. - -=item * Proc (Parser, Target, Data) - -This event is generated when a processing instruction is recognized. - -=item * Comment (Parser, String) - -This event is generated when a comment is recognized. - -=item * CdataStart (Parser) - -This is called at the start of a CDATA section. - -=item * CdataEnd (Parser) - -This is called at the end of a CDATA section. - -=item * Default (Parser, String) - -This is called for any characters that don't have a registered handler. -This includes both characters that are part of markup for which no -events are generated (markup declarations) and characters that -could generate events, but for which no handler has been registered. - -Whatever the encoding in the original document, the string is returned to -the handler in UTF-8. - -=item * Unparsed (Parser, Entity, Base, Sysid, Pubid, Notation) - -This is called for a declaration of an unparsed entity. Entity is the name -of the entity. Base is the base to be used for resolving a relative URI. -Sysid is the system id. Pubid is the public id. Notation is the notation -name. Base and Pubid may be undefined. - -=item * Notation (Parser, Notation, Base, Sysid, Pubid) - -This is called for a declaration of notation. Notation is the notation name. -Base is the base to be used for resolving a relative URI. Sysid is the system -id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined. - -=item * ExternEnt (Parser, Base, Sysid, Pubid) - -This is called when an external entity is referenced. Base is the base to be -used for resolving a relative URI. Sysid is the system id. Pubid is the public -id. Base, and Pubid may be undefined. - -This handler should either return a string, which represents the contents of -the external entity, or return an open filehandle that can be read to obtain -the contents of the external entity, or return undef, which indicates the -external entity couldn't be found and will generate a parse error. - -If an open filehandle is returned, it must be returned as either a glob -(*FOO) or as a reference to a glob (e.g. an instance of IO::Handle). - -=item * ExternEntFin (Parser) - -This is called after an external entity has been parsed. It allows -applications to perform cleanup on actions performed in the above -ExternEnt handler. - -=item * Entity (Parser, Name, Val, Sysid, Pubid, Ndata, IsParam) - -This is called when an entity is declared. For internal entities, the Val -parameter will contain the value and the remaining three parameters will -be undefined. For external entities, the Val parameter -will be undefined, the Sysid parameter will have the system id, the Pubid -parameter will have the public id if it was provided (it will be undefined -otherwise), the Ndata parameter will contain the notation for unparsed -entities. If this is a parameter entity declaration, then the IsParam -parameter is true. - -Note that this handler and the Unparsed handler above overlap. If both are -set, then this handler will not be called for unparsed entities. - -=item * Element (Parser, Name, Model) - -The element handler is called when an element declaration is found. Name is -the element name, and Model is the content model as an -XML::Parser::ContentModel object. See L<"XML::Parser::ContentModel Methods"> -for methods available for this class. - -=item * Attlist (Parser, Elname, Attname, Type, Default, Fixed) - -This handler is called for each attribute in an ATTLIST declaration. -So an ATTLIST declaration that has multiple attributes -will generate multiple calls to this handler. The Elname parameter is the -name of the element with which the attribute is being associated. The Attname -parameter is the name of the attribute. Type is the attribute type, given as -a string. Default is the default value, which will either be "#REQUIRED", -"#IMPLIED" or a quoted string (i.e. the returned string will begin and end -with a quote character). If Fixed is true, then this is a fixed attribute. - -=item * Doctype (Parser, Name, Sysid, Pubid, Internal) - -This handler is called for DOCTYPE declarations. Name is the document type -name. Sysid is the system id of the document type, if it was provided, -otherwise it's undefined. Pubid is the public id of the document type, -which will be undefined if no public id was given. Internal will be -true or false, indicating whether or not the doctype declaration contains -an internal subset. - -=item * DoctypeFin (Parser) - -This handler is called after parsing of the DOCTYPE declaration has finished, -including any internal or external DTD declarations. - -=item * XMLDecl (Parser, Version, Encoding, Standalone) - -This handler is called for XML declarations. Version is a string containg -the version. Encoding is either undefined or contains an encoding string. -Standalone is either undefined, or true or false. Undefined indicates -that no standalone parameter was given in the XML declaration. True or -false indicates "yes" or "no" respectively. - -=back - -=item namespace(name) - -Return the URI of the namespace that the name belongs to. If the name doesn't -belong to any namespace, an undef is returned. This is only valid on names -received through the Start or End handlers from a single document, or through -a call to the generate_ns_name method. In other words, don't use names -generated from one instance of XML::Parser::Expat with other instances. - -=item eq_name(name1, name2) - -Return true if name1 and name2 are identical (i.e. same name and from -the same namespace.) This is only meaningful if both names were obtained -through the Start or End handlers from a single document, or through -a call to the generate_ns_name method. - -=item generate_ns_name(name, namespace) - -Return a name, associated with a given namespace, good for using with the -above 2 methods. The namespace argument should be the namespace URI, not -a prefix. - -=item new_ns_prefixes - -When called from a start tag handler, returns namespace prefixes declared -with this start tag. If called elsewere (or if there were no namespace -prefixes declared), it returns an empty list. Setting of the default -namespace is indicated with '#default' as a prefix. - -=item expand_ns_prefix(prefix) - -Return the uri to which the given prefix is currently bound. Returns -undef if the prefix isn't currently bound. Use '#default' to find the -current binding of the default namespace (if any). - -=item current_ns_prefixes - -Return a list of currently bound namespace prefixes. The order of the -the prefixes in the list has no meaning. If the default namespace is -currently bound, '#default' appears in the list. - -=item recognized_string - -Returns the string from the document that was recognized in order to call -the current handler. For instance, when called from a start handler, it -will give us the the start-tag string. The string is encoded in UTF-8. -This method doesn't return a meaningful string inside declaration handlers. - -=item original_string - -Returns the verbatim string from the document that was recognized in -order to call the current handler. The string is in the original document -encoding. This method doesn't return a meaningful string inside declaration -handlers. - -=item default_current - -When called from a handler, causes the sequence of characters that generated -the corresponding event to be sent to the default handler (if one is -registered). Use of this method is deprecated in favor the recognized_string -method, which you can use without installing a default handler. This -method doesn't deliver a meaningful string to the default handler when -called from inside declaration handlers. - -=item xpcroak(message) - -Concatenate onto the given message the current line number within the -XML document plus the message implied by ErrorContext. Then croak with -the formed message. - -=item xpcarp(message) - -Concatenate onto the given message the current line number within the -XML document plus the message implied by ErrorContext. Then carp with -the formed message. - -=item current_line - -Returns the line number of the current position of the parse. - -=item current_column - -Returns the column number of the current position of the parse. - -=item current_byte - -Returns the current position of the parse. - -=item base([NEWBASE]); - -Returns the current value of the base for resolving relative URIs. If -NEWBASE is supplied, changes the base to that value. - -=item context - -Returns a list of element names that represent open elements, with the -last one being the innermost. Inside start and end tag handlers, this -will be the tag of the parent element. - -=item current_element - -Returns the name of the innermost currently opened element. Inside -start or end handlers, returns the parent of the element associated -with those tags. - -=item in_element(NAME) - -Returns true if NAME is equal to the name of the innermost currently opened -element. If namespace processing is being used and you want to check -against a name that may be in a namespace, then use the generate_ns_name -method to create the NAME argument. - -=item within_element(NAME) - -Returns the number of times the given name appears in the context list. -If namespace processing is being used and you want to check -against a name that may be in a namespace, then use the generate_ns_name -method to create the NAME argument. - -=item depth - -Returns the size of the context list. - -=item element_index - -Returns an integer that is the depth-first visit order of the current -element. This will be zero outside of the root element. For example, -this will return 1 when called from the start handler for the root element -start tag. - -=item skip_until(INDEX) - -INDEX is an integer that represents an element index. When this method -is called, all handlers are suspended until the start tag for an element -that has an index number equal to INDEX is seen. If a start handler has -been set, then this is the first tag that the start handler will see -after skip_until has been called. - - -=item position_in_context(LINES) - -Returns a string that shows the current parse position. LINES should be -an integer >= 0 that represents the number of lines on either side of the -current parse line to place into the returned string. - -=item xml_escape(TEXT [, CHAR [, CHAR ...]]) - -Returns TEXT with markup characters turned into character entities. Any -additional characters provided as arguments are also turned into character -references where found in TEXT. - -=item parse (SOURCE) - -The SOURCE parameter should either be a string containing the whole XML -document, or it should be an open IO::Handle. Only a single document -may be parsed for a given instance of XML::Parser::Expat, so this will croak -if it's been called previously for this instance. - -=item parsestring(XML_DOC_STRING) - -Parses the given string as an XML document. Only a single document may be -parsed for a given instance of XML::Parser::Expat, so this will die if either -parsestring or parsefile has been called for this instance previously. - -This method is deprecated in favor of the parse method. - -=item parsefile(FILENAME) - -Parses the XML document in the given file. Will die if parsestring or -parsefile has been called previously for this instance. - -=item is_defaulted(ATTNAME) - -NO LONGER WORKS. To find out if an attribute is defaulted please use -the specified_attr method. - -=item specified_attr - -When the start handler receives lists of attributes and values, the -non-defaulted (i.e. explicitly specified) attributes occur in the list -first. This method returns the number of specified items in the list. -So if this number is equal to the length of the list, there were no -defaulted values. Otherwise the number points to the index of the -first defaulted attribute name. - -=item finish - -Unsets all handlers (including internal ones that set context), but expat -continues parsing to the end of the document or until it finds an error. -It should finish up a lot faster than with the handlers set. - -=item release - -There are data structures used by XML::Parser::Expat that have circular -references. This means that these structures will never be garbage -collected unless these references are explicitly broken. Calling this -method breaks those references (and makes the instance unusable.) - -Normally, higher level calls handle this for you, but if you are using -XML::Parser::Expat directly, then it's your responsibility to call it. - -=back - -=head2 XML::Parser::ContentModel Methods - -The element declaration handlers are passed objects of this class as the -content model of the element declaration. They also represent content -particles, components of a content model. - -When referred to as a string, these objects are automagicly converted to a -string representation of the model (or content particle). - -=over 4 - -=item isempty - -This method returns true if the object is "EMPTY", false otherwise. - -=item isany - -This method returns true if the object is "ANY", false otherwise. - -=item ismixed - -This method returns true if the object is "(#PCDATA)" or "(#PCDATA|...)*", -false otherwise. - -=item isname - -This method returns if the object is an element name. - -=item ischoice - -This method returns true if the object is a choice of content particles. - - -=item isseq - -This method returns true if the object is a sequence of content particles. - -=item quant - -This method returns undef or a string representing the quantifier -('?', '*', '+') associated with the model or particle. - -=item children - -This method returns undef or (for mixed, choice, and sequence types) -an array of component content particles. There will always be at least -one component for choices and sequences, but for a mixed content model -of pure PCDATA, "(#PCDATA)", then an undef is returned. - -=back - -=head2 XML::Parser::ExpatNB Methods - -The class XML::Parser::ExpatNB is a subclass of XML::Parser::Expat used -for non-blocking access to the expat library. It does not support the parse, -parsestring, or parsefile methods, but it does have these additional methods: - -=over 4 - -=item parse_more(DATA) - -Feed expat more text to munch on. - -=item parse_done - -Tell expat that it's gotten the whole document. - -=back - -=head1 FUNCTIONS - -=over 4 - -=item XML::Parser::Expat::load_encoding(ENCODING) - -Load an external encoding. ENCODING is either the name of an encoding or -the name of a file. The basename is converted to lowercase and a '.enc' -extension is appended unless there's one already there. Then, unless -it's an absolute pathname (i.e. begins with '/'), the first file by that -name discovered in the @Encoding_Path path list is used. - -The encoding in the file is loaded and kept in the %Encoding_Table -table. Earlier encodings of the same name are replaced. - -This function is automaticly called by expat when it encounters an encoding -it doesn't know about. Expat shouldn't call this twice for the same -encoding name. The only reason users should use this function is to -explicitly load an encoding not contained in the @Encoding_Path list. - -=back - -=head1 AUTHORS - -Larry Wall <F<larry@wall.org>> wrote version 1.0. - -Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API -for this version (2.x), provided documentation, and added some standard -package features. - -=cut diff --git a/Master/perltl/site/lib/auto/Tk/Bitmap/Bitmap.dll b/Master/perltl/site/lib/auto/Tk/Bitmap/Bitmap.dll Binary files differdeleted file mode 100644 index f6b75b704c5..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Bitmap/Bitmap.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/CancelRepeat.al b/Master/perltl/site/lib/auto/Tk/CancelRepeat.al deleted file mode 100644 index 82105140755..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Canvas/Canvas.dll b/Master/perltl/site/lib/auto/Tk/Canvas/Canvas.dll Binary files differdeleted file mode 100644 index b6a1321a741..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Canvas/Canvas.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Clipboard/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Clipboard/autosplit.ix deleted file mode 100644 index 360e44863af..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Clipboard/getSelected.al b/Master/perltl/site/lib/auto/Tk/Clipboard/getSelected.al deleted file mode 100644 index 99d70ee5d76..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/EnterFocus.al b/Master/perltl/site/lib/auto/Tk/EnterFocus.al deleted file mode 100644 index 93cc88a8176..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Entry/Entry.dll b/Master/perltl/site/lib/auto/Tk/Entry/Entry.dll Binary files differdeleted file mode 100644 index dd36353deef..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Entry/Entry.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Error.al b/Master/perltl/site/lib/auto/Tk/Error.al deleted file mode 100644 index 4d4f06dc941..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Event/Event.dll b/Master/perltl/site/lib/auto/Tk/Event/Event.dll Binary files differdeleted file mode 100644 index 2339002b71b..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Event/Event.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/FirstMenu.al b/Master/perltl/site/lib/auto/Tk/FirstMenu.al deleted file mode 100644 index c5e12b684e7..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/FocusChildren.al b/Master/perltl/site/lib/auto/Tk/FocusChildren.al deleted file mode 100644 index f6d8f6af753..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/FocusOK.al b/Master/perltl/site/lib/auto/Tk/FocusOK.al deleted file mode 100644 index bffeffba8f4..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/AddScrollbars.al b/Master/perltl/site/lib/auto/Tk/Frame/AddScrollbars.al deleted file mode 100644 index ef3b7537d6e..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/FindMenu.al b/Master/perltl/site/lib/auto/Tk/Frame/FindMenu.al deleted file mode 100644 index b82a61da507..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Frame/autosplit.ix deleted file mode 100644 index 670cd9eb1c4..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/freeze_on_map.al b/Master/perltl/site/lib/auto/Tk/Frame/freeze_on_map.al deleted file mode 100644 index 61697e647fb..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/label.al b/Master/perltl/site/lib/auto/Tk/Frame/label.al deleted file mode 100644 index 3196344c9b8..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/labelPack.al b/Master/perltl/site/lib/auto/Tk/Frame/labelPack.al deleted file mode 100644 index 1dd66963088..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/labelVariable.al b/Master/perltl/site/lib/auto/Tk/Frame/labelVariable.al deleted file mode 100644 index 6a068e32873..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/packscrollbars.al b/Master/perltl/site/lib/auto/Tk/Frame/packscrollbars.al deleted file mode 100644 index 54c59d5bcf2..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/queuePack.al b/Master/perltl/site/lib/auto/Tk/Frame/queuePack.al deleted file mode 100644 index a8a24927d8c..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/sbset.al b/Master/perltl/site/lib/auto/Tk/Frame/sbset.al deleted file mode 100644 index 357fcfd4a4e..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Frame/scrollbars.al b/Master/perltl/site/lib/auto/Tk/Frame/scrollbars.al deleted file mode 100644 index 2a4706eb198..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/ImageNames.al b/Master/perltl/site/lib/auto/Tk/ImageNames.al deleted file mode 100644 index 2a4bd24818a..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/ImageTypes.al b/Master/perltl/site/lib/auto/Tk/ImageTypes.al deleted file mode 100644 index 0f9b8be674a..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/AutoScan.al b/Master/perltl/site/lib/auto/Tk/Listbox/AutoScan.al deleted file mode 100644 index e366618df81..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/BeginExtend.al b/Master/perltl/site/lib/auto/Tk/Listbox/BeginExtend.al deleted file mode 100644 index ad3fe4c6d33..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/BeginSelect.al b/Master/perltl/site/lib/auto/Tk/Listbox/BeginSelect.al deleted file mode 100644 index b29359c70c5..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/BeginToggle.al b/Master/perltl/site/lib/auto/Tk/Listbox/BeginToggle.al deleted file mode 100644 index 3f7ddff4cf9..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al b/Master/perltl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al deleted file mode 100644 index 7461080092f..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/Cancel.al b/Master/perltl/site/lib/auto/Tk/Listbox/Cancel.al deleted file mode 100644 index 3974c2e145c..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/Cntrl_End.al b/Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_End.al deleted file mode 100644 index de53c8048aa..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/Cntrl_Home.al b/Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_Home.al deleted file mode 100644 index 34f09d21bb9..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al b/Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al deleted file mode 100644 index 382a68528a8..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/DataExtend.al b/Master/perltl/site/lib/auto/Tk/Listbox/DataExtend.al deleted file mode 100644 index fdeb0368bba..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/ExtendUpDown.al b/Master/perltl/site/lib/auto/Tk/Listbox/ExtendUpDown.al deleted file mode 100644 index 9c21c0a93a1..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/Listbox.dll b/Master/perltl/site/lib/auto/Tk/Listbox/Listbox.dll Binary files differdeleted file mode 100644 index de4907125a9..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Listbox/Listbox.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Listbox/Motion.al b/Master/perltl/site/lib/auto/Tk/Listbox/Motion.al deleted file mode 100644 index d67ec8121d9..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/SelectAll.al b/Master/perltl/site/lib/auto/Tk/Listbox/SelectAll.al deleted file mode 100644 index 319ce5c2a9c..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/SetList.al b/Master/perltl/site/lib/auto/Tk/Listbox/SetList.al deleted file mode 100644 index 5f4ba81ddf3..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/UpDown.al b/Master/perltl/site/lib/auto/Tk/Listbox/UpDown.al deleted file mode 100644 index e2ce7edce78..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Listbox/autosplit.ix deleted file mode 100644 index 5846f38c4ce..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/clipboardPaste.al b/Master/perltl/site/lib/auto/Tk/Listbox/clipboardPaste.al deleted file mode 100644 index 7deae1e75a4..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/deleteSelected.al b/Master/perltl/site/lib/auto/Tk/Listbox/deleteSelected.al deleted file mode 100644 index 6fc89af9e91..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/getSelected.al b/Master/perltl/site/lib/auto/Tk/Listbox/getSelected.al deleted file mode 100644 index 64706cfa9b4..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Listbox/xyIndex.al b/Master/perltl/site/lib/auto/Tk/Listbox/xyIndex.al deleted file mode 100644 index bfd364a7f9b..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Menubutton/Menubutton.dll b/Master/perltl/site/lib/auto/Tk/Menubutton/Menubutton.dll Binary files differdeleted file mode 100644 index f05f347cc8b..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Menubutton/Menubutton.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Pixmap/Pixmap.dll b/Master/perltl/site/lib/auto/Tk/Pixmap/Pixmap.dll Binary files differdeleted file mode 100644 index 0e887aaefc3..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Pixmap/Pixmap.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Receive.al b/Master/perltl/site/lib/auto/Tk/Receive.al deleted file mode 100644 index e33b6bdc1af..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/RepeatId.al b/Master/perltl/site/lib/auto/Tk/RepeatId.al deleted file mode 100644 index 06728f02221..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Activate.al b/Master/perltl/site/lib/auto/Tk/Scale/Activate.al deleted file mode 100644 index 500358c8e0e..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/ButtonDown.al b/Master/perltl/site/lib/auto/Tk/Scale/ButtonDown.al deleted file mode 100644 index 61ed6f32c11..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/ButtonUp.al b/Master/perltl/site/lib/auto/Tk/Scale/ButtonUp.al deleted file mode 100644 index d5a22a77a46..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/ControlPress.al b/Master/perltl/site/lib/auto/Tk/Scale/ControlPress.al deleted file mode 100644 index 50d7ad8b447..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Drag.al b/Master/perltl/site/lib/auto/Tk/Scale/Drag.al deleted file mode 100644 index 0bc63b12879..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/EndDrag.al b/Master/perltl/site/lib/auto/Tk/Scale/EndDrag.al deleted file mode 100644 index 86037b86d92..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Enter.al b/Master/perltl/site/lib/auto/Tk/Scale/Enter.al deleted file mode 100644 index 1326a5ed9a0..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Increment.al b/Master/perltl/site/lib/auto/Tk/Scale/Increment.al deleted file mode 100644 index 76432eeaf40..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Leave.al b/Master/perltl/site/lib/auto/Tk/Scale/Leave.al deleted file mode 100644 index eb6f7b69f89..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scale/Scale.dll b/Master/perltl/site/lib/auto/Tk/Scale/Scale.dll Binary files differdeleted file mode 100644 index ff1568bcfe6..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Scale/Scale.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Scale/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Scale/autosplit.ix deleted file mode 100644 index a5c5d2292f2..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ButtonDown.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ButtonDown.al deleted file mode 100644 index c17199b73b6..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ButtonUp.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ButtonUp.al deleted file mode 100644 index 24058d857ec..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/Drag.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/Drag.al deleted file mode 100644 index 40d6b0f8d1b..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/EndDrag.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/EndDrag.al deleted file mode 100644 index 5b1fc837326..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/Enter.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/Enter.al deleted file mode 100644 index 45a21f920e5..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/Leave.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/Leave.al deleted file mode 100644 index 349911e304e..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/Motion.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/Motion.al deleted file mode 100644 index 0b414efa389..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al deleted file mode 100644 index bd3d29afa77..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al deleted file mode 100644 index 99e84e394c5..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al deleted file mode 100644 index c3a25af3c19..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al deleted file mode 100644 index 71be23e6794..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll b/Master/perltl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll Binary files differdeleted file mode 100644 index 81eec672093..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Scrollbar/Select.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/Select.al deleted file mode 100644 index 21a743bf7fd..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/StartDrag.al b/Master/perltl/site/lib/auto/Tk/Scrollbar/StartDrag.al deleted file mode 100644 index d544dc53945..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Scrollbar/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Scrollbar/autosplit.ix deleted file mode 100644 index 293d1322dd4..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Selection.al b/Master/perltl/site/lib/auto/Tk/Selection.al deleted file mode 100644 index 0d50a9f31df..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Text/Text.dll b/Master/perltl/site/lib/auto/Tk/Text/Text.dll Binary files differdeleted file mode 100644 index 8cb98c8a455..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Text/Text.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Text/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Text/autosplit.ix deleted file mode 100644 index 48a5455c34a..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Tk.dll b/Master/perltl/site/lib/auto/Tk/Tk.dll Binary files differdeleted file mode 100644 index ee55846fdcb..00000000000 --- a/Master/perltl/site/lib/auto/Tk/Tk.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/Toplevel/FG_BindIn.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_BindIn.al deleted file mode 100644 index cc2ceaf7b63..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/FG_BindOut.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_BindOut.al deleted file mode 100644 index 5c5cf9cc3de..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/FG_Create.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_Create.al deleted file mode 100644 index 0953c045be8..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/FG_Destroy.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_Destroy.al deleted file mode 100644 index e20f1eb7568..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/FG_In.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_In.al deleted file mode 100644 index a4b5c67a155..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/FG_Out.al b/Master/perltl/site/lib/auto/Tk/Toplevel/FG_Out.al deleted file mode 100644 index 96a3841e6fd..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Toplevel/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Toplevel/autosplit.ix deleted file mode 100644 index 6267c58604c..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/TraverseToMenu.al b/Master/perltl/site/lib/auto/Tk/TraverseToMenu.al deleted file mode 100644 index 03b814a1334..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Widget/ASkludge.al b/Master/perltl/site/lib/auto/Tk/Widget/ASkludge.al deleted file mode 100644 index fe9b23df886..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Widget/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Widget/autosplit.ix deleted file mode 100644 index f0a7ffb9891..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Widget/clipboardKeysyms.al b/Master/perltl/site/lib/auto/Tk/Widget/clipboardKeysyms.al deleted file mode 100644 index 71996befb5f..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Widget/pathname.al b/Master/perltl/site/lib/auto/Tk/Widget/pathname.al deleted file mode 100644 index e22439a73cd..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/AnchorAdjust.al b/Master/perltl/site/lib/auto/Tk/Wm/AnchorAdjust.al deleted file mode 100644 index a699cee6920..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/FullScreen.al b/Master/perltl/site/lib/auto/Tk/Wm/FullScreen.al deleted file mode 100644 index 83ab7a3241c..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/Popup.al b/Master/perltl/site/lib/auto/Tk/Wm/Popup.al deleted file mode 100644 index 59a6f496d53..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/Post.al b/Master/perltl/site/lib/auto/Tk/Wm/Post.al deleted file mode 100644 index 277981329b0..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/autosplit.ix b/Master/perltl/site/lib/auto/Tk/Wm/autosplit.ix deleted file mode 100644 index 54b764985de..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/Wm/iconposition.al b/Master/perltl/site/lib/auto/Tk/Wm/iconposition.al deleted file mode 100644 index 6a5b0ec92d8..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/X/X.dll b/Master/perltl/site/lib/auto/Tk/X/X.dll Binary files differdeleted file mode 100644 index 81c220688ae..00000000000 --- a/Master/perltl/site/lib/auto/Tk/X/X.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/Tk/X/autosplit.ix b/Master/perltl/site/lib/auto/Tk/X/autosplit.ix deleted file mode 100644 index e63dbf19b00..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/autosplit.ix b/Master/perltl/site/lib/auto/Tk/autosplit.ix deleted file mode 100644 index 8e8d2880a02..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/break.al b/Master/perltl/site/lib/auto/Tk/break.al deleted file mode 100644 index 388cd46b21b..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/focusFollowsMouse.al b/Master/perltl/site/lib/auto/Tk/focusFollowsMouse.al deleted file mode 100644 index 697e8c61fae..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/focusNext.al b/Master/perltl/site/lib/auto/Tk/focusNext.al deleted file mode 100644 index b5dbc9bc7d6..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/focusPrev.al b/Master/perltl/site/lib/auto/Tk/focusPrev.al deleted file mode 100644 index 77aadf1b929..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/interps.al b/Master/perltl/site/lib/auto/Tk/interps.al deleted file mode 100644 index fe01aa3099f..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/lsearch.al b/Master/perltl/site/lib/auto/Tk/lsearch.al deleted file mode 100644 index 7a597051bec..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/tabFocus.al b/Master/perltl/site/lib/auto/Tk/tabFocus.al deleted file mode 100644 index 4016abff331..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Tk/updateWidgets.al b/Master/perltl/site/lib/auto/Tk/updateWidgets.al deleted file mode 100644 index 0fec5abb3c8..00000000000 --- a/Master/perltl/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/perltl/site/lib/auto/Win32/API/API.dll b/Master/perltl/site/lib/auto/Win32/API/API.dll Binary files differdeleted file mode 100644 index 4c478dc3136..00000000000 --- a/Master/perltl/site/lib/auto/Win32/API/API.dll +++ /dev/null diff --git a/Master/perltl/site/lib/auto/XML/Parser/Expat/Expat.dll b/Master/perltl/site/lib/auto/XML/Parser/Expat/Expat.dll Binary files differdeleted file mode 100644 index be327d38a47..00000000000 --- a/Master/perltl/site/lib/auto/XML/Parser/Expat/Expat.dll +++ /dev/null |
