diff options
Diffstat (limited to 'Master/tlpkg/lib/Perl5_lib-TL_inst/Tk')
25 files changed, 0 insertions, 5792 deletions
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm deleted file mode 100644 index 85a0e406ee5..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm +++ /dev/null @@ -1,104 +0,0 @@ -# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::After; -use Carp; - -use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $ - -sub _cancelAll -{ - my $w = shift; - my $h = delete $w->{_After_}; - foreach my $obj (values %$h) - { - # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; - $obj->cancel; - bless $obj,"Tk::After::Cancelled"; - } -} - -sub Tk::After::Cancelled::once { } -sub Tk::After::Cancelled::repeat { } - -sub submit -{ - my $obj = shift; - my $w = $obj->[0]; - my $id = $obj->[1]; - my $t = $obj->[2]; - my $method = $obj->[3]; - delete($w->{_After_}{$id}) if (defined $id); - $id = $w->Tk::after($t,[$method => $obj]); - unless (exists $w->{_After_}) - { - $w->{_After_} = {}; - $w->OnDestroy([\&_cancelAll, $w]); - } - $w->{_After_}{$id} = $obj; - $obj->[1] = $id; - return $obj; -} - -sub DESTROY -{ - my $obj = shift; - $obj->cancel; - undef $obj->[0]; - undef $obj->[4]; -} - -sub new -{ - my ($class,$w,$t,$method,@cb) = @_; - my $cb = (@cb == 1) ? shift(@cb) : [@cb]; - my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; - return $obj->submit; -} - -sub cancel -{ - my $obj = shift; - my $id = $obj->[1]; - my $w = $obj->[0]; - if ($id) - { - $w->Tk::after('cancel'=> $id) if Tk::Exists($w); - delete $w->{_After_}{$id} if exists $w->{_After_}; - $obj->[1] = undef; - } - return $obj; -} - -sub repeat -{ - my $obj = shift; - $obj->submit; - local $Tk::widget = $obj->[0]; - $obj->[4]->Call; -} - -sub once -{ - my $obj = shift; - my $w = $obj->[0]; - my $id = $obj->[1]; - delete $w->{_After_}{$id}; - local $Tk::widget = $w; - $obj->[4]->Call; -} - -sub time { - my $obj = shift; - my $delay = shift; - if (defined $delay) { - $obj->cancel if $delay == 0; - $obj->[2] = $delay; - } - $obj->[2]; -} - -1; -__END__ - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm deleted file mode 100644 index efa597dee14..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/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-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -use strict; - -require Tk::Widget; -use base qw(Tk::Widget); - -use vars qw($buttonWindow $relief); - -Tk::Methods('deselect','flash','invoke','select','toggle'); - -sub Tk_cmd { \&Tk::button } - -Construct Tk::Widget 'Button'; - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'butDown'); - $mw->bind($class,'<ButtonRelease-1>', 'butUp'); - $mw->bind($class,'<space>', 'Invoke'); - $mw->bind($class,'<Return>', 'Invoke'); - return $class; -} - -# tkButtonEnter -- -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. -# -# Arguments: -# w - The name of the widget. - -sub Enter -{ - my $w = shift; - my $E = shift; - if ($w->cget('-state') ne 'disabled') - { - $w->configure('-state' => 'active'); - $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) - } - $Tk::window = $w; -} - -# tkButtonLeave -- -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. If we're leaving the button window with a mouse button -# pressed (tkPriv(buttonWindow) == $w), restore the relief of the -# button too. -# -# Arguments: -# w - The name of the widget. -sub Leave -{ - my $w = shift; - $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled'); - $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); - undef $Tk::window; -} - -# tkButtonDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. -sub butDown -{ - my $w = shift; - $relief = $w->cget('-relief'); - if ($w->cget('-state') ne 'disabled') - { - $buttonWindow = $w; - $w->configure('-relief' => 'sunken') - } -} - -# tkButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. -# -# Arguments: -# w - The name of the widget. -sub butUp -{ - my $w = shift; - if (defined($buttonWindow) && $buttonWindow == $w) - { - undef $buttonWindow; - $w->configure('-relief' => $relief); - if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') - { - $w->invoke; - } - } -} - -# tkButtonInvoke -- -# The procedure below is called when a button is invoked through -# the keyboard. It simulate a press of the button via the mouse. -# -# Arguments: -# w - The name of the widget. -sub Invoke -{ - my $w = shift; - if ($w->cget('-state') ne 'disabled') - { - my $oldRelief = $w->cget('-relief'); - my $oldState = $w->cget('-state'); - $w->configure('-state' => 'active', '-relief' => 'sunken'); - $w->idletasks; - $w->after(100); - $w->configure('-state' => $oldState, '-relief' => $oldRelief); - $w->invoke; - } -} - - - -1; - -__END__ - - - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm deleted file mode 100644 index 491d8cd2444..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/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-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -require Tk::Widget; -require Tk::Button; - -use base qw(Tk::Button); - -Construct Tk::Widget 'Checkbutton'; - -sub Tk_cmd { \&Tk::checkbutton } - - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'Invoke'); - $mw->bind($class,'<space>', 'Invoke'); - return $class; -} - -sub Invoke -{ - my $w = shift; - $w->invoke() unless($w->cget('-state') eq 'disabled'); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm deleted file mode 100644 index b0eb0ea2b07..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm +++ /dev/null @@ -1,122 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Clipboard; -use strict; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; - -use AutoLoader qw(AUTOLOAD); -use Tk qw(catch); - -sub clipEvents -{ - return qw[Copy Cut Paste]; -} - -sub ClassInit -{ - my ($class,$mw) = @_; - foreach my $op ($class->clipEvents) - { - $mw->Tk::bind($class,"<<$op>>","clipboard$op"); - } - return $class; -} - -sub clipboardSet -{ - my $w = shift; - $w->clipboardClear; - $w->clipboardAppend(@_); -} - -sub clipboardCopy -{ - my $w = shift; - my $val = $w->getSelected; - if (defined $val) - { - $w->clipboardSet('--',$val); - } - return $val; -} - -sub clipboardCut -{ - my $w = shift; - my $val = $w->clipboardCopy; - if (defined $val) - { - $w->deleteSelected; - } - return $val; -} - -sub clipboardGet -{ - my $w = shift; - $w->SelectionGet('-selection','CLIPBOARD',@_); -} - -sub clipboardPaste -{ - my $w = shift; - local $@; - catch - { -## Different from Tcl/Tk version: -# if ($w->windowingsystem eq 'x11') -# { -# catch -# { -# $w->deleteSelected; -# }; -# } - $w->insert("insert", $w->clipboardGet); - $w->SeeInsert if $w->can('SeeInsert'); - }; -} - -sub clipboardOperations -{ - my @class = (); - my $mw = shift; - if (ref $mw) - { - $mw = $mw->DelegateFor('bind'); - } - else - { - push(@class,$mw); - $mw = shift; - } - while (@_) - { - my $op = shift; - $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); - } -} - -# These methods work for Entry and Text -# and can be overridden where they don't work - -sub deleteSelected -{ - my $w = shift; - catch { $w->delete('sel.first','sel.last') }; -} - - -1; -__END__ - -sub getSelected -{ - my $w = shift; - my $val = Tk::catch { $w->get('sel.first','sel.last') }; - return $val; -} - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm deleted file mode 100644 index 2e821e826ae..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/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 = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $ - -use 5.004; - -use strict; - -use Config; - -my $OBJECT = undef; # define the current object - -#/----------------------------------------------------------------------------// -#/ Constructor -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub new # Tk::CmdLine::new() -{ - my $this = shift(@_); - my $class = ref($this) || $this; - - my $name = 'pTk'; - $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); - - my $self = { - name => $name, - config => { -name => $name }, - options => {}, - methods => {}, - command => [], - synchronous => 0, - iconic => 0, - motif => ($Tk::strictMotif || 0), - resources => {} }; - - return bless($self, $class); -} - -#/----------------------------------------------------------------------------// -#/ Process the arguments in a given array or in @ARGV. -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub Argument_ # Tk::CmdLine::Argument_($flag) # private method -{ - my $self = shift(@_); - my $flag = shift(@_); - unless ($self->{offset} < @{$self->{argv}}) - { - die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n"; - } - return splice(@{$self->{argv}}, $self->{offset}, 1); -} - -sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{config}->{"-$name"} = $val; -} - -sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - push(@{$self->{command}}, $flag); - $self->{$name} = 1; -} - -sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{options}->{"*$name"} = $val; -} - -sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{methods}->{$name} = $val; -} - -sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) - { - push(@{$self->{command}}, $flag, $val); - $self->{options}->{$1} = $2; - } -} - -my %Method = ( - background => 'Option_', - bg => 'background', # alias - class => 'Config_', - display => 'screen', # alias - fg => 'foreground', # alias - fn => 'font', # alias - font => 'Option_', - foreground => 'Option_', - geometry => 'Method_', - iconic => 'Flag_', - iconposition => 'Method_', - motif => 'Flag_', - name => 'Config_', - screen => 'Config_', - synchronous => 'Flag_', - title => 'Config_', - xrm => 'Resource_' -); - -sub SetArguments # Tk::CmdLine::SetArguments([@argument]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - $self->{argv} = (@_ ? [ @_ ] : \@ARGV); - $self->{offset} = 0; # its existence will denote that this method has been called - - my @option = (); - - while ($self->{offset} < @{$self->{argv}}) - { - last if ($self->{argv}->[$self->{offset}] eq '--'); - unless ( - (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || - (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) - { - ++$self->{offset}; - next; - } - - next if (!exists($Method{$option[0]}) && ++$self->{offset}); - - $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); - - my $method = $Method{$option[0]}; - - if (@option > 1) # replace --<option>=<value> with <value> - { - $self->{argv}->[$self->{offset}] = $option[1]; - } - else # remove the argument - { - splice(@{$self->{argv}}, $self->{offset}, 1); - } - - $self->$method(('-' . $option[0]), $option[0]); - } - - $self->{config}->{-class} ||= ucfirst($self->{config}->{-name}); - - delete($self->{argv}); # no longer needed - - return $self; -} - -use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy - -#/----------------------------------------------------------------------------// -#/ Get a list of the arguments that have been processed by SetArguments(). -#/ Returns an array. -#/----------------------------------------------------------------------------// - -sub GetArguments # Tk::CmdLine::GetArguments() -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return @{$self->{command}}; -} - -#/----------------------------------------------------------------------------// -#/ Get the value of a configuration option (default: -class). -#/ Returns the option value. -#/----------------------------------------------------------------------------// - -sub cget # Tk::CmdLine::cget([$option]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - my $option = shift(@_) || '-class'; - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef); -} - -#/----------------------------------------------------------------------------// - -sub CreateArgs # Tk::CmdLine::CreateArgs() -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return $self->{config}; -} - -#/----------------------------------------------------------------------------// - -sub Tk::MainWindow::apply_command_line -{ - my $mw = shift(@_); - - my $self = ($OBJECT ||= __PACKAGE__->new()); - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - foreach my $priority (keys(%{$self->{resources}})) - { - foreach my $resource (@{$self->{resources}->{$priority}}) - { - $mw->optionAdd(@{$resource}, $priority); - } - } - - foreach my $key (keys(%{$self->{options}})) - { - $mw->optionAdd($key => $self->{options}->{$key}, 'interactive'); - } - - foreach my $key (keys(%{$self->{methods}})) - { - $mw->$key($self->{methods}->{$key}); - } - - if ($self->{methods}->{geometry}) - { - if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/) - { - $mw->positionfrom('user'); - } - if ($self->{methods}->{geometry} =~ /\d+x\d+/) - { - $mw->sizefrom('user'); - } - delete $self->{methods}->{geometry}; # XXX needed? - } - - $mw->Synchronize() if $self->{synchronous}; - - if ($self->{iconic}) - { - $mw->iconify(); - $self->{iconic} = 0; - } - - $Tk::strictMotif = ($self->{motif} || 0); - - # Both these are needed to reliably save state - # but 'hostname' is tricky to do portably. - # $mw->client(hostname()); - $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]); - $mw->command([ $self->{name}, @{$self->{command}} ]); -} - -#/----------------------------------------------------------------------------// -#/ Set the initial resources. -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - return $self unless @_; - - my $data = shift(@_); - my $priority = shift(@_) || 'userDefault'; - - $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority}); - - foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data) - { - if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format - { - push(@{$self->{resources}->{$priority}}, [ @{$resource} ]) - if (@{$resource} == 2); - } - else # resources in resource file format - { - push(@{$self->{resources}->{$priority}}, [ $1, $2 ]) - if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/); - } - } - - return $self; -} - -#/----------------------------------------------------------------------------// -#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with -#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault'). -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub LoadResources # Tk::CmdLine::LoadResources([%options]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - my %options = @_; - - my @file = (); - my $echo = (exists($options{-echo}) - ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef); - - unless (%options && (exists($options{-file}) || exists($options{-symbol}))) - { - @file = ( - { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' }, - { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } ); - } - else - { - @file = { %options }; - } - - my $delimiter = (($^O eq 'MSWin32') ? ';' : ':'); - - foreach my $file (@file) - { - my $fileSpec = $file->{-spec} = undef; - if (exists($file->{-symbol})) - { - my $xpath = undef; - if ($file->{-symbol} eq 'XUSERFILESEARCHPATH') - { - $file->{-priority} ||= 'userDefault'; - foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME)) - { - last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol})); - } - next unless defined($xpath); - } - else - { - $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH') - ? 'startupFile' : 'userDefault'); - next unless ( - exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}})); - } - - unless (exists($self->{translation})) - { - $self->{translation} = { - '%l' => '', # ignored - '%C' => '', # ignored - '%S' => '', # ignored - '%L' => ($ENV{LANG} || 'C'), # language - '%T' => 'app-defaults', # type - '%N' => $self->{config}->{-class} # filename - }; - } - - my @postfix = map({ $_ . '/' . $self->{config}->{-class} } - ('/' . $self->{translation}->{'%L'}), ''); - - ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath)) - { - if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern - { - if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) - { - print $echo 'Checking ', $fileSpec, "\n"; - } - next unless ((-f $fileSpec) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec; - last; - } - else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS> - { - foreach my $postfix (@postfix) - { - my $fileSpec2 = $fileSpec . $postfix; - if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) - { - print $echo 'Checking ', $fileSpec2, "\n"; - } - next unless ((-f $fileSpec2) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec2; - last ITEM; - } - } - } - } - elsif (exists($file->{-file}) && ($fileSpec = $file->{-file})) - { - print $echo 'Checking ', $fileSpec, "\n" if defined($echo); - next unless ((-f $fileSpec) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec; - } - } - - foreach my $file (@file) - { - next unless defined($file->{-spec}); - local *SPEC; - next unless open(SPEC,$file->{-spec}); - print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo); - - my $resource = undef; - my @resource = (); - my $continuation = 0; - - while (defined(my $line = <SPEC>)) - { - chomp($line); - next if ($line =~ /^\s*$/); # skip blank lines - next if ($line =~ /^\s*!/); # skip comments - $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash - unless (defined($resource)) # it is the first line - { - $resource = $line; - } - else # it is a continuation line - { - $line =~ s/^\s*//; # remove leading whitespace - $resource .= $line; - } - next if $continuation; - push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); - $resource = undef; - } - - close(SPEC); - - if (defined($resource)) # special case - EOF after line with trailing backslash - { - push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); - } - - $self->SetResources(\@resource, $file->{-priority}) if @resource; - } - - return $self; -} - -#/----------------------------------------------------------------------------// - -1; - -__END__ - -=cut - -=head1 NAME - -Tk::CmdLine - Process standard X11 command line options and set initial resources - -=for pm Tk/CmdLine.pm - -=for category Creating and Configuring Widgets - -=head1 SYNOPSIS - - Tk::CmdLine::SetArguments([@argument]); - - my $value = Tk::CmdLine::cget([$option]); - - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]); - - Tk::CmdLine::LoadResources( - [ -symbol => $symbol ] - [ -file => $fileSpec ] - [ -priority => $priority ] - [ -echo => $fileHandle ] ); - -=head1 DESCRIPTION - -Process standard X11 command line options and set initial resources. - -The X11R5 man page for X11 says: "Most X programs attempt to use the same names -for command line options and arguments. All applications written with the -X Toolkit Intrinsics automatically accept the following options: ...". -This module processes these command line options for perl/Tk applications -using the C<SetArguments>() function. - -This module can optionally be used to load initial resources explicitly via -function C<SetResources>(), or from specified files (default: the standard X11 -application-specific resource files) via function C<LoadResources>(). - -=head2 Command Line Options - -=over 4 - -=item B<-background> I<Color> | B<-bg> I<Color> - -Specifies the color to be used for the window background. - -=item B<-class> I<Class> - -Specifies the class under which resources for the application should be found. -This option is useful in shell aliases to distinguish between invocations -of an application, without resorting to creating links to alter the executable -file name. - -=item B<-display> I<Display> | B<-screen> I<Display> - -Specifies the name of the X server to be used. - -=item B<-font> I<Font> | B<-fn> I<Font> - -Specifies the font to be used for displaying text. - -=item B<-foreground> I<Color> | B<-fg> I<Color> - -Specifies the color to be used for text or graphics. - -=item B<-geometry> I<Geometry> - -Specifies the initial size and location of the I<first> -L<MainWindow|Tk::MainWindow>. - -=item B<-iconic> - -Indicates that the user would prefer that the application's windows initially -not be visible as if the windows had been immediately iconified by the user. -Window managers may choose not to honor the application's request. - -=item B<-motif> - -Specifies that the application should adhere as closely as possible to Motif -look-and-feel standards. For example, active elements such as buttons and -scrollbar sliders will not change color when the pointer passes over them. - -=item B<-name> I<Name> - -Specifies the name under which resources for the application should be found. -This option is useful in shell aliases to distinguish between invocations -of an application, without resorting to creating links to alter the executable -file name. - -=item B<-synchronous> - -Indicates that requests to the X server should be sent synchronously, instead of -asynchronously. Since Xlib normally buffers requests to the server, errors do -do not necessarily get reported immediately after they occur. This option turns -off the buffering so that the application can be debugged. It should never -be used with a working program. - -=item B<-title> I<TitleString> - -This option specifies the title to be used for this window. This information is -sometimes used by a window manager to provide some sort of header identifying -the window. - -=item B<-xrm> I<ResourceString> - -Specifies a resource pattern and value to override any defaults. It is also -very useful for setting resources that do not have explicit command line -arguments. - -The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>, -that is (the first) ':' is used to determine which part is pattern and which -part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered -into the options database with B<optionAdd> (for each -L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority. - -=back - -=head2 Initial Resources - -There are several mechanism for initializing the resource database to be used -by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file, -a system application defaults file (e.g. -/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>), -or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>). -The Tk::CmdLine functionality for setting initial resources concerns itself -with the latter two. - -Resource files contain data lines of the form -E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. -They may also contain blank lines and comment lines (denoted -by a ! character as the first non-blank character). Refer to L<option|Tk::option> -for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. - -=over 4 - -=item System Application Defaults Files - -System application defaults files may be specified via environment variable -$C<XFILESEARCHPATH> which, if set, contains a list of file patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). - -=item User Application Defaults Files - -User application defaults files may be specified via environment variables -$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>. - -=back - -=head1 METHODS - -=over 4 - -=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument]) - -Extract the X11 options contained in a specified array (@ARGV by default). - - Tk::CmdLine::SetArguments([@argument]) - -The X11 options may be specified using a single dash I<-> as per the X11 -convention, or using two dashes I<--> as per the POSIX standard (e.g. -B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>). -The options may be interspersed with other options or arguments. -A I<--> by itself terminates option processing. - -By default, command line options are extracted from @ARGV the first time -a MainWindow is created. The Tk::MainWindow constructor indirectly invokes -C<SetArguments>() to do this. - -=item B<GetArguments> - Tk::CmdLine::GetArguments() - -Get a list of the X11 options that have been processed by C<SetArguments>(). -(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.) - -=item B<cget> - Tk::CmdLine::cget([$option]) - -Get the value of a configuration option specified via C<SetArguments>(). -(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.) - - Tk::CmdLine::cget([$option]) - -The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>. -If no option is specified, B<-class> is implied. - -A typical use of C<cget>() might be to obtain the application class in order -to define the name of a resource file to be loaded in via C<LoadResources>(). - - my $class = Tk::CmdLine::cget(); # process command line and return class - -=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) - -Set the initial resources. - - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) - -A single resource may be specified using a string of the form -'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified -by passing an array reference whose elements are either strings of the above -form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>, -E<lt>I<value>E<gt> ]. The optional second argument specifies the priority, -as defined in L<option|Tk::option>, to be associated with the resources -(default: I<userDefault>). - -Note that C<SetResources>() first invokes C<SetArguments>() if it has not already -been invoked. - -=item B<LoadResources> - Tk::CmdLine::LoadResources([%options]) - -Load initial resources from one or more files. - - Tk::CmdLine::LoadResources( - [ -symbol => $symbol ] - [ -file => $fileSpec ] - [ -priority => $priority ] - [ -echo => $fileHandle ] ); - -[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable -that, if set, defines a list of one or more directories and/or file patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). -$C<XUSERFILESEARCHPATH> is a special case. -If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead. -If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead. - -An item is identified as a file pattern if it contains one or more /%[A-Za-z]/ -patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All -others are replaced with the null string. Pattern B<%L> is translated into -$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is -translated into the application class name. - -Each file pattern, after substitutions are applied, is assumed to define a -FileSpec to be examined. - -When a directory is specified, FileSpecs -E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt> -and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order. - -[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in. -The file is silently skipped if if does not exist, or if it is not readable. - -[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in -L<option|Tk::option>, to be associated with the resources -(default: I<userDefault>). - -[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be -printed to the corresponding FileHandle (default: \*STDOUT) everytime a file -is examined / loaded. - -If no B<-symbol> or B<-file> options are specified, C<LoadResources>() -processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and -$C<XUSERFILESEARCHPATH> with priority I<userDefault>. -(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to -contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single -directory. C<LoadResources>() does not check/care whether this is the case.) - -For each set of FileSpecs, C<LoadResources>() examines each FileSpec to -determine if the file exists and is readable. The first file that meets this -criteria is read in and C<SetResources>() is invoked. - -Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already -been invoked. - -=back - -=head1 NOTES - -This module is an object-oriented module whose methods can be invoked as object -methods, class methods or regular functions. This is accomplished via an -internally-maintained object reference which is created as necessary, and which -always points to the last object used. C<SetArguments>(), C<SetResources>() and -C<LoadResources>() return the object reference. - -=head1 EXAMPLES - -=over - -=item 1 - -@ARGV is processed by Tk::CmdLine at MainWindow creation. - - use Tk; - - # <Process @ARGV - ignoring all X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 2 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -An @ARGV of (--geometry=100x100 -opt1 a b c -bg red) -is equal to (-opt1 a b c) after C<SetArguments>() is invoked. - - use Tk; - - Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too - - # <Process @ARGV - not worrying about X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 3 - -Just like 2) except that default arguments are loaded first. - - use Tk; - - Tk::CmdLine::SetArguments(qw(-name test -iconic)); - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 4 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(); - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 5 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation -using non-default priorities. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(-echo => \*STDOUT, - -priority => 65, -symbol => 'XFILESEARCHPATH' ); - Tk::CmdLine::LoadResources(-echo => \*STDOUT, - -priority => 75, -symbol => 'XUSERFILESEARCHPATH' ); - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 6 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation. -Individual resources are also loaded in before MainWindow creation. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(); - - Tk::CmdLine::SetResources( # set a single resource - '*Button*background: red', - 'widgetDefault' ); - - Tk::CmdLine::SetResources( # set multiple resources - [ '*Button*background: red', '*Button*foreground: blue' ], - 'widgetDefault' ); - - my $mw = MainWindow->new(); - - MainLoop(); - -=back - -=head1 ENVIRONMENT - -=over 4 - -=item B<HOME> (optional) - -Home directory which may contain user application defaults files as -$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>. - -=item B<LANG> (optional) - -The current language (default: I<C>). - -=item B<XFILESEARCHPATH> (optional) - -List of FileSpec patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) -used in defining system application defaults files. - -=item B<XUSERFILESEARCHPATH> (optional) - -List of FileSpec patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) -used in defining user application defaults files. - -=item B<XAPPLRESDIR> (optional) - -Directory containing user application defaults files as -$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or -$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>. - -=back - -=head1 SEE ALSO - -L<MainWindow|Tk::MainWindow> -L<option|Tk::option> - -=head1 HISTORY - -=over 4 - -=item * - -1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> - -Rewritten as an object-oriented module. - -Allow one to process command line options in a specified array (@ARGV by default). -Eliminate restrictions on the format and location of the options within the array -(previously the X11 options could not be specified in POSIX format and had to be -at the beginning of the array). - -Added the C<SetResources>() and C<LoadResources>() functions to allow the definition -of resources prior to MainWindow creation. - -=item * - -2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> - -Added the C<GetArguments>() method which returns the list of arguments that -have been processed by C<SetArguments>(). - -Modified C<LoadResources>() to split the symbols using the OS-dependent -path delimiter defined in the B<Config> module. - -Modified C<LoadResources>() to eliminate a warning message when processing -patterns B<%l>, B<%C>, B<%S>. - -=back - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm deleted file mode 100644 index 26252ae4958..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm +++ /dev/null @@ -1,69 +0,0 @@ -package Tk::Configure; -use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $ - -use Carp; -use Tk::Pretty; - - -# Class that handles cget/configure for options that -# need translating from public form -# e.g. $cw->configure(-label => 'fred') -# into $cw->subwiget('label')->configure(-text => 'fred') -# Should probably do something clever with regexp's here - - -sub new -{ - my ($class,@args) = @_; - unshift(@args,'configure','cget') if (@args < 3); - return bless \@args,$class; -} - -sub cget -{ - croak('Wrong number of args to cget') unless (@_ == 2); - my ($alias,$key) = @_; - my ($set,$get,$widget,@args) = @$alias; - $widget->$get(@args); -} - -sub configure -{ - my $alias = shift; - shift if (@_); - my ($set,$get,$widget,@args) = @$alias; - if (wantarray) - { - my @results; - eval { @results = $widget->$set(@args,@_) }; - croak($@) if $@; - return @results; - } - else - { - my $results; - eval { $results = $widget->$set(@args,@_) }; - croak($@) if $@; - return $results; - } -} - -*TIESCALAR = \&new; -*TIEHASH = \&new; - -sub FETCH -{ - my $alias = shift; - my ($set,$get,$widget,@args) = @$alias; - return $widget->$get(@args,@_); -} - -sub STORE -{ - my $alias = shift; - my ($set,$get,$widget,@args) = @$alias; - $widget->$set(@args,@_); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm deleted file mode 100644 index c31c205d2fb..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm +++ /dev/null @@ -1,512 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Derived; -require Tk::Widget; -require Tk::Configure; -use strict; -use Carp; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; - -$Tk::Derived::Debug = 0; - -my $ENHANCED_CONFIGSPECS = 0; # disable for now - -use Tk qw(NORMAL_BG BLACK); - -sub Subwidget -{ - my $cw = shift; - my @result = (); - if (exists $cw->{SubWidget}) - { - if (@_) - { - foreach my $name (@_) - { - push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name}); - } - } - else - { - @result = values %{$cw->{SubWidget}}; - } - } - return (wantarray) ? @result : $result[0]; -} - -sub _makelist -{ - my $widget = shift; - my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget); - return @specs; -} - -sub Subconfigure -{ - # This finds the widget or widgets to to which to apply a particular - # configure option - my ($cw,$opt) = @_; - my $config = $cw->ConfigSpecs; - my $widget; - my @subwidget = (); - my @arg = (); - if (defined $opt) - { - $widget = $config->{$opt}; - unless (defined $widget) - { - $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt}; - } - # Handle alias entries - if (defined($widget) && !ref($widget)) - { - $opt = $widget; - $widget = $config->{$widget}; - } - push(@arg,$opt) unless ($opt eq 'DEFAULT'); - } - $widget = $config->{DEFAULT} unless (defined $widget); - if (defined $widget) - { - $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY')); - $widget = $widget->[0]; - } - else - { - $widget = 'SELF'; - } - foreach $widget (_makelist($widget)) - { - $widget = 'SELF' if (ref($widget) && $widget == $cw); - if (ref $widget) - { - my $ref = ref $widget; - if ($ref eq 'ARRAY') - { - $widget = Tk::Configure->new(@$widget); - push(@subwidget,$widget) - } - elsif ($ref eq 'HASH') - { - foreach my $key (%$widget) - { - foreach my $sw (_makelist($widget->{$key})) - { - push(@subwidget,Tk::Configure->new($sw,$key)); - } - } - } - else - { - push(@subwidget,$widget) - } - } - elsif ($widget eq 'ADVERTISED') - { - push(@subwidget,$cw->Subwidget) - } - elsif ($widget eq 'DESCENDANTS') - { - push(@subwidget,$cw->Descendants) - } - elsif ($widget eq 'CHILDREN') - { - push(@subwidget,$cw->children) - } - elsif ($widget eq 'METHOD') - { - my ($method) = ($opt =~ /^-?(.*)$/); - push(@subwidget,Tk::Configure->new($method,$method,$cw)) - } - elsif ($widget eq 'SETMETHOD') - { - my ($method) = ($opt =~ /^-?(.*)$/); - push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg)) - } - elsif ($widget eq 'SELF') - { - push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg)) - } - elsif ($widget eq 'PASSIVE') - { - push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg)) - } - elsif ($widget eq 'CALLBACK') - { - push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg)) - } - else - { - push(@subwidget,$cw->Subwidget($widget)); - } - } - $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget); - return (wantarray) ? @subwidget : $subwidget[0]; -} - -sub _cget -{ - my ($cw,$opt) = @_; - $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2); - return $cw->{Configure}{$opt} -} - -sub _configure -{ - my ($cw,$opt,$val) = @_; - $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); - $cw->{Configure}{$opt} = $val; -} - -sub _callback -{ - my ($cw,$opt,$val) = @_; - $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); - $val = Tk::Callback->new($val) if defined($val) && ref($val); - $cw->{Configure}{$opt} = $val; -} - -sub cget -{my ($cw,$opt) = @_; - my @result; - local $SIG{'__DIE__'}; - foreach my $sw ($cw->Subconfigure($opt)) - { - if (wantarray) - { - eval { @result = $sw->cget($opt) }; - } - else - { - eval { $result[0] = $sw->cget($opt) }; - } - last unless $@; - } - return wantarray ? @result : $result[0]; -} - -sub Configured -{ - # Called whenever a derived widget is re-configured - my ($cw,$args,$changed) = @_; - if (@_ > 1) - { - $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed); - } - return exists $cw->{'Configure'}; -} - -sub configure -{ - # The default composite widget configuration method uses hash stored - # in the widget's hash to map configuration options - # onto subwidgets. - # - my @results = (); - my $cw = shift; - if (@_ <= 1) - { - # Enquiry cases - my $spec = $cw->ConfigSpecs; - if (@_) - { - # Return info on the nominated option - my $opt = $_[0]; - my $info = $spec->{$opt}; - unless (defined $info) - { - $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt}; - } - if (defined $info) - { - if (ref $info) - { - # If the default slot is undef then ask subwidgets in turn - # for their default value until one accepts it. - if ($ENHANCED_CONFIGSPECS && !defined($info->[3])) - {local $SIG{'__DIE__'}; - my @def; - foreach my $sw ($cw->Subconfigure($opt)) - { - eval { @def = $sw->configure($opt) }; - last unless $@; - } - $info->[3] = $def[3]; - $info->[1] = $def[1] unless defined $info->[1]; - $info->[2] = $def[2] unless defined $info->[2]; - } - push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt)); - } - else - { - # Real (core) Tk widgets return db name rather than option name - # for aliases so recurse to get that ... - my @real = $cw->configure($info); - push(@results,$opt,$real[1]); - } - } - else - { - push(@results,$cw->Subconfigure($opt)->configure($opt)); - } - } - else - { - my $opt; - my %results; - if (exists $spec->{'DEFAULT'}) - { - foreach $opt ($cw->Subconfigure('DEFAULT')->configure) - { - $results{$opt->[0]} = $opt; - } - } - foreach $opt (keys %$spec) - { - $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT'); - } - foreach $opt (sort keys %results) - { - push(@results,$results{$opt}); - } - } - } - else - { - my (%args) = @_; - my %changed = (); - my ($opt,$val); - my $config = $cw->TkHash('Configure'); - - while (($opt,$val) = each %args) - { - my $var = \$config->{$opt}; - my $old = $$var; - $$var = $val; - my $accepted = 0; - my $error = "No widget handles $opt"; - foreach my $subwidget ($cw->Subconfigure($opt)) - { - next unless (defined $subwidget); - eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) }; - if ($@) - { - my $val2 = (defined $val) ? $val : 'undef'; - $error = "Can't set $opt to `$val2' for $cw: " . $@; - undef $@; - } - else - { - $accepted = 1; - } - } - $cw->BackTrace($error) unless ($accepted); - $val = $$var; - $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val"); - } - $cw->Configured(\%args,\%changed); - } - return (wantarray) ? @results : \@results; -} - -sub ConfigDefault -{ - my ($cw,$args) = @_; - - $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH'); - - my $specs = $cw->ConfigSpecs; - # Should we enforce a Delagates(DEFAULT => ) as well ? - $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'}); - - # - # This is a pain with Text or Entry as core widget, they don't - # inherit SELF's cursor. So comment it out for Tk402.001 - # - # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'}); - - # Now some hacks that cause colours to propogate down a composite widget - # tree - really needs more thought, other options adding such as active - # colours too and maybe fonts - - my $child = ($cw->children)[0]; # 1st child window (if any) - - unless (exists($specs->{'-background'})) - { - Tk::catch { $cw->Tk::cget('-background') }; - my (@bg) = $@ ? ('PASSIVE') : ('SELF'); - push(@bg,'CHILDREN') if $child; - $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; - } - unless (exists($specs->{'-foreground'})) - { - Tk::catch { $cw->Tk::cget('-foreground') }; - my (@fg) = $@ ? ('PASSIVE') : ('SELF'); - push(@fg,'CHILDREN') if $child; - $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; - } - $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); - - # Pre-scan args for aliases - this avoids defaulting - # options specified via alias - foreach my $opt (keys %$args) - { - my $info = $specs->{$opt}; - if (defined($info) && !ref($info)) - { - $args->{$info} = delete $args->{$opt}; - } - } - - # Now walk %$specs supplying defaults for all the options - # which have a defined default value, potentially looking up .Xdefaults database - # options for the name/class of the 'frame' - - foreach my $opt (keys %$specs) - { - if ($opt ne 'DEFAULT') - { - unless (exists $args->{$opt}) - { - my $info = $specs->{$opt}; - if (ref $info) - { - # Not an alias - if ($ENHANCED_CONFIGSPECS && !defined $info->[3]) - { - # configure inquire to fill in default slot from subwidget - $cw->configure($opt); - } - if (defined $info->[3]) - { - if (defined $info->[1] && defined $info->[2]) - { - # Should we do this on the Subconfigure widget instead? - # to match *Entry.Background - my $db = $cw->optionGet($info->[1],$info->[2]); - $info->[3] = $db if (defined $db); - } - $args->{$opt} = $info->[3]; - } - } - } - } - } -} - -sub ConfigSpecs -{ - my $cw = shift; - my $specs = $cw->TkHash('ConfigSpecs'); - while (@_) - { - my $key = shift; - my $val = shift; - $specs->{$key} = $val; - } - return $specs; -} - -sub _alias -{ - my ($specs,$opt,$main) = @_; - if (exists($specs->{$opt})) - { - unless (exists $specs->{$main}) - { - my $targ = $specs->{$opt}; - if (ref($targ)) - { - # opt is a real option - $specs->{$main} = $opt - } - else - { - # opt is itself an alias - # make main point to same place - $specs->{$main} = $targ unless $targ eq $main; - } - } - return 1; - } - return 0; -} - -sub ConfigAlias -{ - my $cw = shift; - my $specs = $cw->ConfigSpecs; - while (@_ >= 2) - { - my $opt = shift; - my $main = shift; - unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt)) - { - $cw->BackTrace("Neither $opt nor $main exist"); - } - } - $cw->BackTrace('Odd number of args to ConfigAlias') if (@_); -} - -sub Delegate -{ - my ($cw,$method,@args) = @_; - my $widget = $cw->DelegateFor($method); - if ($widget == $cw) - { - $method = "Tk::Widget::$method" - } - my @result; - if (wantarray) - { - @result = $widget->$method(@args); - } - else - { - $result[0] = $widget->$method(@args); - } - return (wantarray) ? @result : $result[0]; -} - -sub InitObject -{ - my ($cw,$args) = @_; - $cw->Populate($args); - $cw->ConfigDefault($args); -} - -sub ConfigChanged -{ - my ($cw,$args) = @_; -} - -sub Advertise -{ - my ($cw,$name,$widget) = @_; - confess 'No name' unless (defined $name); - croak 'No widget' unless (defined $widget); - my $hash = $cw->TkHash('SubWidget'); - $hash->{$name} = $widget; # advertise it - return $widget; -} - -sub Component -{ - my ($cw,$kind,$name,%args) = @_; - $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'}); - # my $pack = delete $args{'-pack'}; - my $delegate = delete $args{'-delegate'}; - my $w = $cw->$kind(%args); # Create it - # $w->pack(@$pack) if (defined $pack); - $cw->Advertise($name,$w) if (defined $name); - $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); - return $w; # and return it -} - -1; -__END__ - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm deleted file mode 100644 index 8173f4a5acc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Tk::Dialog; - -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $ - -# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on -# John Stoffel's idea). -# -# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27 -# lusol@Lehigh.EDU - -# Documentation after __END__ - -use Carp; -use strict; -use base qw(Tk::DialogBox); - -Construct Tk::Widget 'Dialog'; - -sub Populate -{ - - # Dialog object constructor. Uses `new' method from base class - # to create object container then creates the dialog toplevel. - - my($cw, $args) = @_; - - $cw->SUPER::Populate($args); - - my ($w_bitmap,$w_but,$pad1,$pad2); - - # Create the Toplevel window and divide it into top and bottom parts. - - my (@pl) = (-side => 'top', -fill => 'both'); - - ($pad1, $pad2) = - ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']); - - - $cw->iconname('Dialog'); - - my $w_top = $cw->Subwidget('top'); - - # Fill the top part with the bitmap and message. - - @pl = (-side => 'left'); - - $w_bitmap = $w_top->Label(Name => 'bitmap'); - $w_bitmap->pack(@pl, @$pad1); - - my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' ); - - $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1); - - $cw->Advertise(message => $w_msg); - $cw->Advertise(bitmap => $w_bitmap ); - - $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef], - -bitmap => ['bitmap',undef,undef,undef], - -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'], - DEFAULT => ['message',undef,undef,undef] - ); -} - -1; - -__END__ - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm deleted file mode 100644 index 13335404e15..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm +++ /dev/null @@ -1,135 +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 = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; - -use base qw(Tk::Toplevel); - -Tk::Widget->Construct('DialogBox'); - -sub Populate { - my ($cw, $args) = @_; - - $cw->SUPER::Populate($args); - my $buttons = delete $args->{'-buttons'}; - $buttons = ['OK'] unless defined $buttons; - my $default_button = delete $args->{'-default_button'}; - $default_button = $buttons->[0] unless defined $default_button; - - $cw->{'selected_button'} = ''; - $cw->transient($cw->Parent->toplevel); - $cw->withdraw; - if (@$buttons == 1) { - $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke }); - } else { - $cw->protocol('WM_DELETE_WINDOW' => sub {}); - } - - # create the two frames - my $top = $cw->Component('Frame', 'top'); - $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; - my $bot = $cw->Component('Frame', 'bottom'); - $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; - $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); - $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); - - # create a row of buttons in the bottom. - my $bl; # foreach my $var: perl > 5.003_08 - foreach $bl (@$buttons) - { - my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); - $b->bind('<Return>' => [ $b, 'Invoke']); - $cw->Advertise("B_$bl" => $b); - if ($Tk::platform eq 'MSWin32') - { - $b->configure(-width => 10, -pady => 0); - } - if ($bl eq $default_button) { - if ($Tk::platform eq 'MSWin32') { - $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } else { - my $db = $bot->Frame(-relief => 'sunken', -bd => 1); - $b->raise($db); - $b->pack(-in => $db, -padx => '2', -pady => '2'); - $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } - $cw->{'default_button'} = $b; - $cw->bind('<Return>' => [ $b, 'Invoke']); - } else { - $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } - } - $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], - -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], - -background => ['DESCENDANTS', 'background','Background', undef], - -focus => ['PASSIVE', undef, undef, undef], - -showcommand => ['CALLBACK', undef, undef, undef], - ); - $cw->Delegates('Construct',$top); -} - -sub add { - my ($cw, $wnam, @args) = @_; - my $w = $cw->Subwidget('top')->$wnam(@args); - $cw->Advertise("\L$wnam" => $w); - return $w; -} - -sub Wait -{ - my $cw = shift; - $cw->Callback(-showcommand => $cw); - $cw->waitVariable(\$cw->{'selected_button'}); - $cw->grabRelease; - $cw->withdraw; - $cw->Callback(-command => $cw->{'selected_button'}); -} - -sub Show { - - croak 'DialogBox: "Show" method requires at least 1 argument' - if scalar @_ < 1; - my $cw = shift; - my ($grab) = @_; - my $old_focus = $cw->focusSave; - my $old_grab = $cw->grabSave; - - shift if defined $grab && length $grab && ($grab =~ /global/); - $cw->Popup(@_); - - Tk::catch { - if (defined $grab && length $grab && ($grab =~ /global/)) { - $cw->grabGlobal; - } else { - $cw->grab; - } - }; - if (my $focusw = $cw->cget(-focus)) { - $focusw->focus; - } elsif (defined $cw->{'default_button'}) { - $cw->{'default_button'}->focus; - } else { - $cw->focus; - } - $cw->Wait; - &$old_focus; - &$old_grab; - return $cw->{'selected_button'}; -} - -sub Exit -{ - my $cw = shift; - #kill the dialogbox, by faking a 'DONE' - $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm deleted file mode 100644 index 5ead808405d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm +++ /dev/null @@ -1,46 +0,0 @@ -package Tk::DummyEncode; - -use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $ - -sub getEncoding -{ - my ($class,$name) = @_; - return undef unless ($name =~ /(iso8859-1|X11ControlChars)/); - my $pkg = $name; - $pkg =~ s/\W+/_/g; - return bless {Name => $name},$class.'::'.$pkg; -} - -package Tk::DummyEncode::iso8859_1; -sub encode -{ - my ($obj,$uni,$chk) = @_; - $_[1] = '' if $chk; - return $uni; -} - -sub decode -{ - my ($obj,$byt,$chk) = @_; - $_[1] -= '' if $chk; - return $byt; -} - -package Tk::DummyEncode::X11ControlChars; -sub encode -{ - my ($obj,$uni,$chk) = @_; - my $str = ''; - foreach my $ch (split(//,$uni)) - { - $str .= sprintf("\\x{%x}",ord($ch)); - } - $_[1] = '' if $chk; - return $str; -} - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm deleted file mode 100644 index 51b3f0c6767..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm +++ /dev/null @@ -1,615 +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-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -use vars qw($VERSION); -use strict; -$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -use Tk::Widget (); -use Tk::Clipboard (); -use base qw(Tk::Clipboard Tk::Widget); - -import Tk qw(Ev $XS_VERSION); - -Construct Tk::Widget 'Entry'; - -bootstrap Tk::Entry; - -sub Tk_cmd { \&Tk::entry } - -Tk::Methods('bbox','delete','get','icursor','index','insert','scan', - 'selection','validate','xview'); - -use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], - 'xview' => [qw(moveto scroll)], - ); - -sub wordstart -{my ($w,$pos) = @_; - my $string = $w->get; - $pos = $w->index('insert')-1 unless(defined $pos); - $string = substr($string,0,$pos); - $string =~ s/\S*$//; - length $string; -} - -sub wordend -{my ($w,$pos) = @_; - my $string = $w->get; - my $anc = length $string; - $pos = $w->index('insert') unless(defined $pos); - $string = substr($string,$pos); - $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; - $anc - length($string); -} - -sub deltainsert -{ - my ($w,$d) = @_; - return $w->index('insert')+$d; -} - -# -# Bind -- -# This procedure is invoked the first time the mouse enters an -# entry widget or an entry widget receives the input focus. It creates -# all of the class bindings for entries. -# -# Arguments: -# event - Indicates which event caused the procedure to be invoked -# (Enter or FocusIn). It is used so that we can carry out -# the functions of that event in addition to setting up -# bindings. -sub ClassInit -{ - my ($class,$mw) = @_; - - $class->SUPER::ClassInit($mw); - - # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard - $mw->bind($class,'<<Clear>>' => sub { - my $w = shift; - $w->delete("sel.first", "sel.last"); - }); - $mw->bind($class,'<<PasteSelection>>' => [sub { - my($w, $x) = @_; - # XXX logic in Tcl/Tk version screwed up? - if (!$Tk::strictMotif && !$Tk::mouseMoved) { - $w->Paste($x); - } - }, Ev('x')]); - - # Standard Motif bindings: - # The <Escape> binding is different from the Tcl/Tk version: - $mw->bind($class,'<Escape>','selectionClear'); - - $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); - $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]); - $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]); - - $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']); - $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']); - $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]); - $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']); - - $mw->bind($class,'<Shift-1>','Shift_1'); - - - $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]); - $mw->bind($class,'<B1-Enter>','CancelRepeat'); - $mw->bind($class,'<Control-1>','Control_1'); - $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]); - $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]); - $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]); - $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]); - $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]); - $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]); - $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]); - $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]); - $mw->bind($class,'<Home>',['SetCursor',0]); - $mw->bind($class,'<Shift-Home>',['KeySelect',0]); - $mw->bind($class,'<End>',['SetCursor','end']); - $mw->bind($class,'<Shift-End>',['KeySelect','end']); - $mw->bind($class,'<Delete>','Delete'); - - $mw->bind($class,'<BackSpace>','Backspace'); - - $mw->bind($class,'<Control-space>',['selectionFrom','insert']); - $mw->bind($class,'<Select>',['selectionFrom','insert']); - $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']); - $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']); - - $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']); - $mw->bind($class,'<Control-backslash>','selectionClear'); - - # $class->clipboardOperations($mw,qw[Copy Cut Paste]); - - $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]); - - # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. - # Otherwise, if a widget binding for one of these is defined, the - # <KeyPress> class binding will also fire and insert the character, - # which is wrong. Ditto for Return, and Tab. - - $mw->bind($class,'<Alt-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Meta-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Control-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Return>' ,'NoOp'); - $mw->bind($class,'<KP_Enter>' ,'NoOp'); - $mw->bind($class,'<Tab>' ,'NoOp'); - if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) - { - $mw->bind($class,'<Command-KeyPress>', 'NoOp'); - } - - # On Windows, paste is done using Shift-Insert. Shift-Insert already - # generates the <<Paste>> event, so we don't need to do anything here. - if ($Tk::platform ne 'MSWin32') - { - $mw->bind($class,'<Insert>','InsertSelection'); - } - - if (!$Tk::strictMotif) - { - # Additional emacs-like bindings: - $mw->bind($class,'<Control-a>',['SetCursor',0]); - $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]); - $mw->bind($class,'<Control-d>',['delete','insert']); - $mw->bind($class,'<Control-e>',['SetCursor','end']); - $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]); - $mw->bind($class,'<Control-h>','Backspace'); - $mw->bind($class,'<Control-k>',['delete','insert','end']); - - $mw->bind($class,'<Control-t>','Transpose'); - - # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead - $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]); - $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]); - $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]); - $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']); - $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']); - - # A few additional bindings from John Ousterhout. -# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']); - $mw->bind($class,'<2>','Button_2'); - $mw->bind($class,'<B2-Motion>','B2_Motion'); -# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2'); - } - return $class; -} - - -sub Shift_1 -{ - my $w = shift; - my $Ev = $w->XEvent; - $Tk::selectMode = 'char'; - $w->selectionAdjust('@' . $Ev->x) -} - - -sub Control_1 -{ - my $w = shift; - my $Ev = $w->XEvent; - $w->icursor('@' . $Ev->x) -} - - -sub Delete -{ - my $w = shift; - if ($w->selectionPresent) - { - $w->deleteSelected - } - else - { - $w->delete('insert') - } -} - - -sub InsertSelection -{ - my $w = shift; - eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} -} - - -# Original is ::tk::EntryScanMark -sub Button_2 -{ - my $w = shift; - my $Ev = $w->XEvent; - $w->scan('mark',$Ev->x); - $Tk::x = $Ev->x; - $Tk::y = $Ev->y; - $Tk::mouseMoved = 0 -} - - -# Original is ::tk::EntryScanDrag -sub B2_Motion -{ - my $w = shift; - my $Ev = $w->XEvent; - # Make sure these exist, as some weird situations can trigger the - # motion binding without the initial press. [Tcl/Tk Bug #220269] - if (!defined $Tk::x) { $Tk::x = $Ev->x } - if (abs(($Ev->x-$Tk::x)) > 2) - { - $Tk::mouseMoved = 1 - } - $w->scan('dragto',$Ev->x) -} - - -# XXX Not needed anymore -sub ButtonRelease_2 -{ - my $w = shift; - my $Ev = $w->XEvent; - if (!$Tk::mouseMoved) - { - eval - {local $SIG{__DIE__}; - $w->insert('insert',$w->SelectionGet); - $w->SeeInsert; - } - } -} - -sub Button1Release -{ - shift->CancelRepeat; -} - -# ::tk::EntryClosestGap -- -# Given x and y coordinates, this procedure finds the closest boundary -# between characters to the given coordinates and returns the index -# of the character just after the boundary. -# -# Arguments: -# w - The entry window. -# x - X-coordinate within the window. -sub ClosestGap -{ - my($w, $x) = @_; - my $pos = $w->index('@'.$x); - my @bbox = $w->bbox($pos); - if ($x - $bbox[0] < $bbox[2] / 2) - { - return $pos; - } - $pos + 1; -} - -# Button1 -- -# This procedure is invoked to handle button-1 presses in entry -# widgets. It moves the insertion cursor, sets the selection anchor, -# and claims the input focus. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the button press. -sub Button1 -{ - my $w = shift; - my $x = shift; - $Tk::selectMode = 'char'; - $Tk::mouseMoved = 0; - $Tk::pressX = $x; - $w->icursor($w->ClosestGap($x)); - $w->selectionFrom('insert'); - $w->selectionClear; - if ($w->cget('-state') ne 'disabled') - { - $w->focus() - } -} - -sub Motion -{ - my ($w,$x,$y) = @_; - $Tk::x = $x; # XXX ? - $w->MouseSelect($x); -} - -# MouseSelect -- -# This procedure is invoked when dragging out a selection with -# the mouse. Depending on the selection mode (character, word, -# line) it selects in different-sized units. This procedure -# ignores mouse motions initially until the mouse has moved from -# one character to another or until there have been multiple clicks. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the mouse. -sub MouseSelect -{ - - my $w = shift; - my $x = shift; - return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; - $Tk::selectMode = shift if (@_); - my $cur = $w->index($w->ClosestGap($x)); - return unless defined $cur; - my $anchor = $w->index('anchor'); - return unless defined $anchor; - $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? - if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) - { - $Tk::mouseMoved = 1 - } - my $mode = $Tk::selectMode; - return unless $mode; - if ($mode eq 'char') - { - # The Tcl version uses selectionRange here XXX - if ($Tk::mouseMoved) - { - if ($cur < $anchor) - { - $w->selectionTo($cur) - } - else - { - $w->selectionTo($cur+1) - } - } - } - elsif ($mode eq 'word') - { - # The Tcl version uses tcl_wordBreakBefore/After here XXX - if ($cur < $w->index('anchor')) - { - $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) - } - else - { - $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) - } - } - elsif ($mode eq 'line') - { - $w->selectionRange(0,'end') - } - if (@_) - { - my $ipos = shift; - eval {local $SIG{__DIE__}; $w->icursor($ipos) }; - } - $w->idletasks; -} -# ::tk::EntryPaste -- -# This procedure sets the insertion cursor to the current mouse position, -# pastes the selection there, and sets the focus to the window. -# -# Arguments: -# w - The entry window. -# x - X position of the mouse. -sub Paste -{ - my($w, $x) = @_; - $w->icursor($w->ClosestGap($x)); - eval { local $SIG{__DIE__}; - $w->insert("insert", $w->GetSelection); - $w->SeeInsert; # Perl/Tk extension - }; - if ($w->cget(-state) ne 'disabled') - { - $w->focus; - } -} -# AutoScan -- -# This procedure is invoked when the mouse leaves an entry window -# with button 1 down. It scrolls the window left or right, -# depending on where the mouse is, and reschedules itself as an -# 'after' command so that the window continues to scroll until the -# mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The entry window. -# x - The x-coordinate of the mouse when it left the window. -sub AutoScan -{ - my $w = shift; - my $x = shift; - return if !Tk::Exists($w); - if ($x >= $w->width) - { - $w->xview('scroll',2,'units') - } - elsif ($x < 0) - { - $w->xview('scroll',-2,'units') - } - else - { - return; - } - $w->MouseSelect($x); - $w->RepeatId($w->after(50,['AutoScan',$w,$x])) -} -# KeySelect -# This procedure is invoked when stroking out selections using the -# keyboard. It moves the cursor to a new position, then extends -# the selection to that position. -# -# Arguments: -# w - The entry window. -# new - A new position for the insertion cursor (the cursor hasn't -# actually been moved to this position yet). -sub KeySelect -{ - my $w = shift; - my $new = shift; - if (!$w->selectionPresent) - { - $w->selectionFrom('insert'); - $w->selectionTo($new) - } - else - { - $w->selectionAdjust($new) - } - $w->icursor($new); - $w->SeeInsert; -} -# Insert -- -# Insert a string into an entry at the point of the insertion cursor. -# If there is a selection in the entry, and it covers the point of the -# insertion cursor, then delete the selection before inserting. -# -# Arguments: -# w - The entry window in which to insert the string -# s - The string to insert (usually just a single character) -sub Insert -{ - my $w = shift; - my $s = shift; - return unless (defined $s && $s ne ''); - eval - {local $SIG{__DIE__}; - my $insert = $w->index('insert'); - if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) - { - $w->deleteSelected - } - }; - $w->insert('insert',$s); - $w->SeeInsert -} -# Backspace -- -# Backspace over the character just before the insertion cursor. -# -# Arguments: -# w - The entry window in which to backspace. -sub Backspace -{ - my $w = shift; - if ($w->selectionPresent) - { - $w->deleteSelected - } - else - { - my $x = $w->index('insert')-1; - $w->delete($x) if ($x >= 0); - # XXX Missing repositioning part from Tcl/Tk source - } -} -# SeeInsert -# Make sure that the insertion cursor is visible in the entry window. -# If not, adjust the view so that it is. -# -# Arguments: -# w - The entry window. -sub SeeInsert -{ - my $w = shift; - my $c = $w->index('insert'); -# -# Probably a bug in your version of tcl/tk (I've not this problem -# when I test Entry in the widget demo for tcl/tk) -# index('\@0') give always 0. Consequence : -# if you make <Control-E> or <Control-F> view is adapted -# but with <Control-A> or <Control-B> view is not adapted -# - my $left = $w->index('@0'); - if ($left > $c) - { - $w->xview($c); - return; - } - my $x = $w->width; - while ($w->index('@' . $x) <= $c && $left < $c) - { - $left += 1; - $w->xview($left) - } -} -# SetCursor -# Move the insertion cursor to a given position in an entry. Also -# clears the selection, if there is one in the entry, and makes sure -# that the insertion cursor is visible. -# -# Arguments: -# w - The entry window. -# pos - The desired new position for the cursor in the window. -sub SetCursor -{ - my $w = shift; - my $pos = shift; - $w->icursor($pos); - $w->selectionClear; - $w->SeeInsert; -} -# Transpose -# This procedure implements the 'transpose' function for entry widgets. -# It tranposes the characters on either side of the insertion cursor, -# unless the cursor is at the end of the line. In this case it -# transposes the two characters to the left of the cursor. In either -# case, the cursor ends up to the right of the transposed characters. -# -# Arguments: -# w - The entry window. -sub Transpose -{ - my $w = shift; - my $i = $w->index('insert'); - $i++ if ($i < $w->index('end')); - my $first = $i-2; - return if ($first < 0); - my $str = $w->get; - my $new = substr($str,$i-1,1) . substr($str,$first,1); - $w->delete($first,$i); - $w->insert('insert',$new); - $w->SeeInsert; -} - -sub tabFocus -{ - my $w = shift; - $w->selectionRange(0,'end'); - $w->icursor('end'); - $w->SUPER::tabFocus; -} - -# ::tk::EntryGetSelection -- -# -# Returns the selected text of the entry with respect to the -show option. -# -# Arguments: -# w - The entry window from which the text to get -sub getSelected -{ - my $w = shift; - return undef unless $w->selectionPresent; - my $str = $w->get; - my $show = $w->cget('-show'); - $str = $show x length($str) if (defined $show); - my $s = $w->index('sel.first'); - my $e = $w->index('sel.last'); - return substr($str,$s,$e-$s); -} - - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm deleted file mode 100644 index cecd57c54ae..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm +++ /dev/null @@ -1,13 +0,0 @@ -package Tk::Event; -use vars qw($VERSION $XS_VERSION @EXPORT_OK); -END { CleanupGlue() } -$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; -$XS_VERSION = '804.027'; -use base qw(Exporter); -use XSLoader; -@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS - TIMER_EVENTS IDLE_EVENTS ALL_EVENTS); -XSLoader::load 'Tk::Event',$XS_VERSION; -require Tk::Event::IO; -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm deleted file mode 100644 index 10b47e246ff..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm +++ /dev/null @@ -1,132 +0,0 @@ -package Tk::Event::IO; -use strict; -use Carp; - -use vars qw($VERSION @EXPORT_OK); -$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; - -use base qw(Exporter); -use Symbol (); - -@EXPORT_OK = qw(READABLE WRITABLE); - -sub PrintArgs -{ - my $func = (caller(1))[3]; - print "$func(",join(',',@_),")\n"; -} - -sub PRINT -{ - my $obj = shift; - $obj->wait(WRITABLE); - my $h = $obj->handle; - return print $h @_; -} - -sub PRINTF -{ - my $obj = shift; - $obj->wait(WRITABLE); - my $h = $obj->handle; - return printf $h @_; -} - -sub WRITE -{ - my $obj = $_[0]; - $obj->wait(WRITABLE); - return syswrite($obj->handle,$_[1],$_[2]); -} - -my $depth = 0; -sub READLINE -{ - my $obj = shift; - $obj->wait(READABLE); - my $h = $obj->handle; - my $w = <$h>; - return $w; -} - -sub READ -{ - my $obj = $_[0]; - $obj->wait(READABLE); - my $h = $obj->handle; - return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0); -} - -sub GETC -{ - my $obj = $_[0]; - $obj->wait(READABLE); - my $h = $obj->handle; - return getc($h); -} - -sub CLOSE -{ - my $obj = shift; - $obj->unwatch; - my $h = $obj->handle; - return close($h); -} - -sub EOF -{ - my $obj = shift; - my $h = $obj->handle; - return eof($h); -} - -sub FILENO -{ - my $obj = shift; - my $h = $obj->handle; - return fileno($h); -} - -sub imode -{ - my $mode = shift; - my $imode = ${{'readable' => READABLE(), - 'writable' => WRITABLE()}}{$mode}; - croak("Invalid handler type '$mode'") unless (defined $imode); - return $imode; -} - -sub fileevent -{ - my ($widget,$file,$mode,$cb) = @_; - my $imode = imode($mode); - unless (ref $file) - { - no strict 'refs'; - $file = Symbol::qualify($file,(caller)[0]); - $file = \*{$file}; - } - my $obj = tied(*$file); - unless ($obj && $obj->isa('Tk::Event::IO')) - { - $obj = tie *$file,'Tk::Event::IO', $file; - } - if (@_ == 3) - { - # query return the handler - return $obj->handler($imode); - } - else - { - # set the handler - my $h = $obj->handler($imode,$cb); - undef $obj; # Prevent warnings about untie with ref to object - unless ($h) - { - untie *$file; - } - } -} - -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm deleted file mode 100644 index a5716cdf9bd..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm +++ /dev/null @@ -1,378 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Frame; -require Tk::Widget; -require Tk::Derived; -use AutoLoader; -use strict qw(vars); -use Carp; - -use base qw(Tk::Derived Tk::Widget); - -Construct Tk::Widget 'Frame'; - -use vars qw($VERSION); -$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $ - -sub Tk_cmd { \&Tk::frame } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') -} - -sub Default -{ - my ($cw,$name,$widget) = @_; - confess 'No name' unless (defined $name); - croak 'No widget' unless (defined $widget); - $cw->Delegates(DEFAULT => $widget); - $cw->ConfigSpecs(DEFAULT => [$widget]); - $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect - $cw->Advertise($name,$widget); -} - -sub ConfigDelegate -{ - my ($cw,$name,@skip) = @_; - my $sw = $cw->Subwidget($name); - my $sc; - my %skip = (); - foreach $sc (@skip) - { - $skip{$sc} = 1; - } - foreach $sc ($sw->configure) - { - my (@info) = @$sc; - next if (@info == 2); - my $option = $info[0]; - unless ($skip{$option}) - { - $option =~ s/^-(.*)/-$name\u$1/; - $info[0] = Tk::Configure->new($sw,$info[0]); - pop(@info); - $cw->ConfigSpecs($option => \@info); - } - } -} - -sub bind -{my ($cw,@args) = @_; - $cw->Delegate('bind',@args); -} - -sub menu -{my ($cw,@args) = @_; - $cw->Delegate('menu',@args); -} - -sub focus -{my ($cw,@args) = @_; - $cw->Delegate('focus',@args); -} - -#sub bindtags -#{my ($cw,@args) = @_; -# $cw->Delegate('bindtags',@args); -#} - -sub selection -{my ($cw,@args) = @_; - $cw->Delegate('selection',@args); -} - -sub autoLabel { 1 } - -sub Populate -{ - my ($cw,$args) = @_; - if ($cw->autoLabel) - { - $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); - $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); - $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); - $cw->labelPack([]) if grep /^-label\w+/, keys %$args; - } -} - -sub Menubar -{ - my $frame = shift; - my $menu = $frame->cget('-menu'); - if (defined $menu) - { - $menu->configure(@_) if @_; - } - else - { - $menu = $frame->Menu(-type => 'menubar',@_); - $frame->configure('-menu' => $menu); - } - $frame->Advertise('menubar' => $menu); - return $menu; -} - -1; - -__END__ - -sub labelPack -{ - my ($cw,$val) = @_; - my $w = $cw->Subwidget('label'); - my @result = (); - if (@_ > 1) - { - if (defined($w) && !defined($val)) - { - $w->packForget; - } - elsif (defined($val) && !defined ($w)) - { - require Tk::Label; - $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); - $cw->Advertise('label' => $w); - $cw->ConfigDelegate('label',qw(-text -textvariable)); - } - if (defined($val) && defined($w)) - { - my %pack = @$val; - unless (exists $pack{-side}) - { - $pack{-side} = 'top' unless (exists $pack{-side}); - } - unless (exists $pack{-fill}) - { - $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); - $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); - } - unless (exists($pack{'-before'}) || exists($pack{'-after'})) - { - my $before = ($cw->packSlaves)[0]; - $pack{'-before'} = $before if (defined $before); - } - $w->pack(%pack); - } - } - @result = $w->packInfo if (defined $w); - return (wantarray) ? @result : \@result; -} - -sub labelVariable -{ - my ($cw,$val) = @_; - my $var = \$cw->{Configure}{'-labelVariable'}; - if (@_ > 1 && defined $val) - { - $$var = $val; - $$val = '' unless (defined $$val); - my $w = $cw->Subwidget('label'); - unless (defined $w) - { - $cw->labelPack([]); - $w = $cw->Subwidget('label'); - } - $w->configure(-textvariable => $val); - } - return $$var; -} - -sub label -{ - my ($cw,$val) = @_; - my $var = $cw->cget('-labelVariable'); - if (@_ > 1 && defined $val) - { - if (!defined $var) - { - $var = \$cw->{Configure}{'-label'}; - $cw->labelVariable($var); - } - $$var = $val; - } - return (defined $var) ? $$var : undef;; -} - -sub queuePack -{ - my ($cw) = @_; - unless ($cw->{'pack_pending'}) - { - $cw->{'pack_pending'} = 1; - $cw->afterIdle([$cw,'packscrollbars']); - } -} - -sub sbset -{ - my ($cw,$sb,$ref,@args) = @_; - $sb->set(@args); - $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); -} - -sub freeze_on_map -{ - my ($w) = @_; - unless ($w->Tk::bind('Freeze','<Map>')) - { - $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) - } - $w->AddBindTag('Freeze'); -} - -sub AddScrollbars -{ - require Tk::Scrollbar; - my ($cw,$w) = @_; - my $def = ''; - my ($x,$y) = ('',''); - my $s = 0; - my $c; - $cw->freeze_on_map; - foreach $c ($w->configure) - { - my $opt = $c->[0]; - if ($opt eq '-yscrollcommand') - { - my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); - my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); - my $size = $ysb->cget('-width'); - my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', - '-width' => $size, '-height' => $size); - $ysb->pack(-side => 'left', -fill => 'y'); - $cw->Advertise('yscrollbar' => $ysb); - $cw->Advertise('corner' => $corner); - $cw->Advertise('ysbslice' => $slice); - $corner->{'before'} = $ysb->PathName; - $slice->{'before'} = $w->PathName; - $y = 'w'; - $s = 1; - } - elsif ($opt eq '-xscrollcommand') - { - my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); - $cw->Advertise('xscrollbar' => $xsb); - $xsb->{'before'} = $w->PathName; - $x = 's'; - $s = 1; - } - } - if ($s) - { - $cw->Advertise('scrolled' => $w); - $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); - } -} - -sub packscrollbars -{ - my ($cw) = @_; - my $opt = $cw->cget('-scrollbars'); - my $slice = $cw->Subwidget('ysbslice'); - my $xsb = $cw->Subwidget('xscrollbar'); - my $corner = $cw->Subwidget('corner'); - my $w = $cw->Subwidget('scrolled'); - my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); - my $havex = 0; - my $havey = 0; - $opt =~ s/r//; - $cw->{'pack_pending'} = 0; - if (defined $slice) - { - my $reqy; - my $ysb = $cw->Subwidget('yscrollbar'); - if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) - { - my $yside = (($opt =~ /w/) ? 'left' : 'right'); - $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); - $havey = 1; - if ($reqy) - { - $w->configure(-yscrollcommand => ['set', $ysb]); - } - else - { - $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); - } - } - else - { - $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; - $slice->packForget; - } - $cw->{'packysb'} = $havey; - } - if (defined $xsb) - { - my $reqx; - if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) - { - $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); - $havex = 1; - if ($reqx) - { - $w->configure(-xscrollcommand => ['set', $xsb]); - } - else - { - $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); - } - } - else - { - $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; - $xsb->packForget; - } - $cw->{'packxsb'} = $havex; - } - if (defined $corner) - { - if ($havex && $havey && defined $corner->{'before'}) - { - my $anchor = $opt; - $anchor =~ s/o//g; - $corner->configure(-height => $xsb->ReqHeight); - $corner->pack(-before => $corner->{'before'}, -side => $xside, - -anchor => $anchor, -fill => 'x'); - } - else - { - $corner->packForget; - } - } -} - -sub scrollbars -{ - my ($cw,$opt) = @_; - my $var = \$cw->{'-scrollbars'}; - if (@_ > 1) - { - my $old = $$var; - if (!defined $old || $old ne $opt) - { - $$var = $opt; - $cw->queuePack; - } - } - return $$var; -} - -sub FindMenu -{ - my ($w,$char) = @_; - my $child; - my $match; - foreach $child ($w->children) - { - next unless (ref $child); - $match = $child->FindMenu($char); - return $match if (defined $match); - } - return undef; -} - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm deleted file mode 100644 index 0f41c387fc2..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm +++ /dev/null @@ -1,74 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Image; - -# This module does for images what Tk::Widget does for widgets: -# provides a base class for them to inherit from. -require DynaLoader; - -use base qw(DynaLoader Tk); # but are they ? - -use vars qw($VERSION); -$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ - -sub new -{ - my $package = shift; - my $widget = shift; - $package->InitClass($widget); - my $leaf = $package->Tk_image; - my $obj = $widget->Tk::image('create',$leaf,@_); - $obj = $widget->_object($obj) unless (ref $obj); - return bless $obj,$package; -} - -sub Install -{ - # Dynamically loaded image types can install standard images here - my ($class,$mw) = @_; -} - -sub ClassInit -{ - # Carry out class bindings (or whatever) - my ($package,$mw) = @_; - return $package; -} - -require Tk::Submethods; - -Direct Tk::Submethods ('image' => [qw(delete width height type)]); - -sub Tk::Widget::imageNames -{ - my $w = shift; - $w->image('names',@_); -} - -sub Tk::Widget::imageTypes -{ - my $w = shift; - map("\u$_",$w->image('types',@_)); -} - -sub Construct -{ - my ($base,$name) = @_; - my $class = (caller(0))[0]; - - # Hack for broken ->isa in perl5.6.0 - delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; - - *{"Tk::Widget::$name"} = sub { $class->new(@_) }; -} - -# This is here to prevent AUTOLOAD trying to find it. -sub DESTROY -{ - my $i = shift; - # maybe do image delete ??? -} - - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm deleted file mode 100644 index ebea1741c2f..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm +++ /dev/null @@ -1,21 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Tk::Label; -require Tk; - - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $ - -use base qw(Tk::Widget); - -Construct Tk::Widget 'Label'; - -sub Tk_cmd { \&Tk::label } - -1; - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm deleted file mode 100644 index 5384ccb560b..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm +++ /dev/null @@ -1,213 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::MainWindow; -use base qw(Tk::Toplevel); -BEGIN { @MainWindow::ISA = 'Tk::MainWindow' } - -use strict; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; - -use Tk::CmdLine; -use Tk qw(catch); -require Tk::Toplevel; - -use Carp; - -$| = 1; - -my $pid = $$; - -my %Windows = (); - -sub CreateArgs -{ - my ($class,$args) = @_; - my $cmd = Tk::CmdLine->CreateArgs(); - my $key; - foreach $key (keys %$cmd) - { - $args->{$key} = $cmd->{$key} unless exists $args->{$key}; - } - my %result = $class->SUPER::CreateArgs(undef,$args); - my $name = delete($args->{'-name'}); - unless (Tk::tainting) - { - $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'}); - $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'}; - } - return (-name => "\l$name",%result); -} - -sub new -{ - my $package = shift; - if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/) - { - carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W; - unshift(@_,'-screen'); - } - croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2; - my %args = @_; - - my $top = eval { bless Create($package->CreateArgs(\%args)), $package }; - croak($@ . "$package->new(" . join(',',@_) .')') if ($@); - $top->apply_command_line; - $top->InitBindings; - $top->SetBindtags; - $top->InitObject(\%args); - eval { $top->configure(%args) }; - croak "$@" if ($@); - if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') { - my $geometry = $top->optionGet(qw(geometry Geometry)); - if ($geometry) { - $top->geometry($geometry); - } - } - $Windows{$top} = $top; - return $top; -} - -sub _Destroyed -{ - my $top = shift; - $top->SUPER::_Destroyed; - delete $Windows{$top}; -} - -sub InitBindings -{ - my $mw = shift; - $mw->bind('all','<Tab>','focusNext'); - # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk - $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]); - # This is needed for XFree86 systems - catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) }; - # This seems to be correct on *some* HP systems. - catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) }; - $mw->bind('all','<<LeftTab>>','focusPrev'); - if ($mw->windowingsystem eq 'x11') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14> - <Control-Key-underscore>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]); - } - elsif ($mw->windowingsystem eq 'win32') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]); - } - elsif ($mw->windowingsystem eq 'aqua') - { - $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]); - $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]); - $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Clear>> <Clear>]); - $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]); - $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]); - } - elsif ($mw->windowingsystem eq 'classic') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Clear>> <Clear>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]); - } - - # FIXME - Should these move to Menubutton ? - my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; - $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]); - $mw->bind($c,'<F10>','FirstMenu'); -} - -sub Existing -{ - my @Windows; - foreach my $name (keys %Windows) - { - my $obj = $Windows{$name}; - if (Tk::Exists($obj)) - { - push(@Windows,$obj); - } - else - { - delete $Windows{$name}; - } - } - return @Windows; -} - -END -{ - if (Tk::IsParentProcess()) - { - foreach my $top (values %Windows) - { - if ($top->IsWidget) - { - # Tk data structuctures are still in place - # this can occur if non-callback perl code did a 'die'. - # It will also handle some cases of non-Tk 'exit' being called - # Destroy this mainwindow and hence is descendants ... - $top->destroy; - } - } - } -} - -sub CmdLine { return shift->command } - -sub WMSaveYourself -{ - my $mw = shift; - my @args = @{$mw->command}; -# warn 'preWMSaveYourself:'.join(' ',@args)."\n"; - @args = ($0) unless (@args); - my $i = 1; - while ($i < @args) - { - if ($args[$i] eq '-iconic') - { - splice(@args,$i,1); - } - elsif ($args[$i] =~ /^-(geometry|iconposition)$/) - { - splice(@args,$i,2); - } - } - - my @ip = $mw->wm('iconposition'); -# print 'ip ',join(',',@ip),"\n"; - my $icon = $mw->iconwindow; - if (defined($icon)) - { - @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/; - } - splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2); - - splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic'); - - splice(@args,1,0,'-geometry' => $mw->geometry); -# warn 'postWMSaveYourself:'.join(' ',@args)."\n"; - $mw->command([@args]); -} - -1; - -__END__ - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm deleted file mode 100644 index 1ecb4001d17..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm +++ /dev/null @@ -1,43 +0,0 @@ -package Tk::PNG; -require DynaLoader; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/; - -use Tk 800.005; -require Tk::Image; -require Tk::Photo; - -use base qw(DynaLoader); - -bootstrap Tk::PNG $Tk::VERSION; - -1; - -__END__ - -=head1 NAME - -Tk::PNG - PNG loader for Tk::Photo - -=head1 SYNOPSIS - - use Tk; - use Tk::PNG; - - my $image = $widget->Photo('-format' => 'png', -file => 'something.png'); - - -=head1 DESCRIPTION - -This is an extension for Tk800.* which supplies -PNG format loader for Photo image type. - - -=head1 AUTHOR - -Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> - -=cut - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm deleted file mode 100644 index a596dc4d78b..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm +++ /dev/null @@ -1,22 +0,0 @@ -package Tk::Photo; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/; - -use Tk qw($XS_VERSION); - -use base qw(Tk::Image); - -Construct Tk::Image 'Photo'; - -sub Tk_image { 'photo' } - -Tk::Methods('blank','copy','data','formats','get','put','read', - 'redither','transparency','write'); - -use Tk::Submethods ( - 'transparency' => [qw/get set/], -); - -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm deleted file mode 100644 index 7e442a4bcbc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm +++ /dev/null @@ -1,93 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Pretty; -require Exporter; - -use vars qw($VERSION @EXPORT); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $ - -use base qw(Exporter); - -@EXPORT = qw(Pretty PrintArgs); - -sub pretty_list -{ - join(',',map(&Pretty($_),@_)); -} - -sub Pretty -{ - return pretty_list(@_) if (@_ > 1); - my $obj = shift; - return 'undef' unless defined($obj); - my $type = "$obj"; - return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"})); - my $result = ''; - if (ref $obj) - { - my $class; - if ($type =~ /^([^=]+)=(.*)$/) - { - $class = $1; - $type = $2; - $result .= 'bless('; - } - if ($type =~ /^ARRAY/) - { - $result .= '['; - $result .= pretty_list(@$obj); - $result .= ']'; - } - elsif ($type =~ /^HASH/) - { - $result .= '{'; - if (%$obj) - { - my ($key, $value); - while (($key,$value) = each %$obj) - { - $result .= $key . '=>' . Pretty($value) . ','; - } - chop($result); - } - $result .= '}'; - } - elsif ($type =~ /^REF/) - { - $result .= "\\" . Pretty($$obj); - } - elsif ($type =~ /^SCALAR/) - { - $result .= Pretty($$obj); - } - else - { - $result .= $type; - } - $result .= ",$class)" if (defined $class); - } - else - { - if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ || - $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ || - $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/ - ) - { - $result .= $obj; - } - else - { - $result .= "'" . $obj . "'"; - } - } - return $result; -} - -sub PrintArgs -{ - my $name = (caller(1))[3]; - print "$name(",Pretty(@_),")\n"; -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm deleted file mode 100644 index d09d41b4208..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/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-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -package Tk::Radiobutton; - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -require Tk::Button; - - -use base qw(Tk::Button); -Construct Tk::Widget 'Radiobutton'; - -sub Tk_cmd { \&Tk::radiobutton } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-variable'); -} - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'Invoke'); - $mw->bind($class,'<space>', 'Invoke'); - return $class; -} - -sub Invoke -{ - my $w = shift; - $w->invoke() unless($w->cget('-state') eq 'disabled'); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm deleted file mode 100644 index a2b8e3bd186..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm +++ /dev/null @@ -1,46 +0,0 @@ -package Tk::Submethods; - -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $ - -sub import -{ - my $class = shift; - no strict 'refs'; - my $package = caller(0); - while (@_) - { - my $fn = shift; - my $sm = shift; - foreach my $sub (@{$sm}) - { - my ($suffix) = $sub =~ /(\w+)$/; - my $pfn = $package.'::'.$fn; - *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) }; - } - } -} - -sub Direct -{ - my $class = shift; - no strict 'refs'; - my $package = caller(0); - while (@_) - { - my $fn = shift; - my $sm = shift; - my $sub; - foreach $sub (@{$sm}) - { - # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }"; - *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) }; - } - } -} - -1; - -__END__ - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm deleted file mode 100644 index 7bcd156d475..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm +++ /dev/null @@ -1,211 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Toplevel; -use AutoLoader; - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $ - -use base qw(Tk::Wm Tk::Frame); - -Construct Tk::Widget 'Toplevel'; - -sub Tk_cmd { \&Tk::toplevel } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-screen','-use') -} - -sub Populate -{ - my ($cw,$arg) = @_; - $cw->SUPER::Populate($arg); - $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]); -} - -sub Icon -{ - my ($top,%args) = @_; - my $icon = $top->iconwindow; - my $state = $top->state; - if ($state ne 'withdrawn') - { - $top->withdraw; - $top->update; # Let attributes propogate - } - unless (defined $icon) - { - $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon'); - $icon->withdraw; - # Fake Populate - my $lab = $icon->Component('Label' => 'icon'); - $lab->pack('-expand'=>1,'-fill' => 'both'); - $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']); - # Now do tail of InitObject - $icon->ConfigDefault(\%args); - # And configure that new would have done - $top->iconwindow($icon); - $top->update; - $lab->DisableButtonEvents; - $lab->update; - } - $top->iconimage($args{'-image'}) if (exists $args{'-image'}); - $icon->configure(%args); - $icon->idletasks; # Let size request propogate - $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight); - $icon->update; # Let attributes propogate - $top->deiconify if ($state eq 'normal'); - $top->iconify if ($state eq 'iconic'); -} - -sub menu -{ - my $w = shift; - my $menu; - $menu = $w->cget('-menu'); - unless (defined $menu) - { - $w->configure(-menu => ($menu = $w->SUPER::menu)) - } - $menu->configure(@_) if @_; - return $menu; -} - - -1; -__END__ - -#---------------------------------------------------------------------- -# -# Focus Group -# -# Focus groups are used to handle the user's focusing actions inside a -# toplevel. -# -# One example of using focus groups is: when the user focuses on an -# entry, the text in the entry is highlighted and the cursor is put to -# the end of the text. When the user changes focus to another widget, -# the text in the previously focused entry is validated. -# - -#---------------------------------------------------------------------- -# tkFocusGroup_Create -- -# -# Create a focus group. All the widgets in a focus group must be -# within the same focus toplevel. Each toplevel can have only -# one focus group, which is identified by the name of the -# toplevel widget. -# -sub FG_Create { - my $t = shift; - unless (exists $t->{'_fg'}) { - $t->{'_fg'} = 1; - $t->bind('<FocusIn>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_In($w, $Ev->d); - } - ); - $t->bind('<FocusOut>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_Out($w, $Ev->d); - } - ); - $t->bind('<Destroy>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_Destroy($w); - } - ); - # <Destroy> is not sufficient to break loops if never mapped. - $t->OnDestroy([$t,'FG_Destroy']); - } -} - -# tkFocusGroup_BindIn -- -# -# Add a widget into the "FocusIn" list of the focus group. The $cmd will be -# called when the widget is focused on by the user. -# -sub FG_BindIn { - my($t, $w, $cmd) = @_; - $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); - $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd); -} - -# tkFocusGroup_BindOut -- -# -# Add a widget into the "FocusOut" list of the focus group. The -# $cmd will be called when the widget loses the focus (User -# types Tab or click on another widget). -# -sub FG_BindOut { - my($t, $w, $cmd) = @_; - $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); - $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd); -} - -# tkFocusGroup_Destroy -- -# -# Cleans up when members of the focus group is deleted, or when the -# toplevel itself gets deleted. -# -sub FG_Destroy { - my($t, $w) = @_; - if (!defined($w) || $t == $w) { - delete $t->{'_fg'}; - delete $t->{'_focus'}; - delete $t->{'_FocusOut'}; - delete $t->{'_FocusIn'}; - } else { - if (exists $t->{'_focus'}) { - delete $t->{'_focus'} if ($t->{'_focus'} == $w); - } - delete $t->{'_FocusIn'}{$w}; - delete $t->{'_FocusOut'}{$w}; - } -} - -# tkFocusGroup_In -- -# -# Handles the <FocusIn> event. Calls the FocusIn command for the newly -# focused widget in the focus group. -# -sub FG_In { - my($t, $w, $detail) = @_; - if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) { - # This is already in focus - return; - } else { - $t->{'_focus'} = $w; - $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w}; - } -} - -# tkFocusGroup_Out -- -# -# Handles the <FocusOut> event. Checks if this is really a lose -# focus event, not one generated by the mouse moving out of the -# toplevel window. Calls the FocusOut command for the widget -# who loses its focus. -# -sub FG_Out { - my($t, $w, $detail) = @_; - if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') { - # This is caused by mouse moving out of the window - return; - } - unless (exists $t->{'_FocusOut'}{$w}) { - return; - } else { - $t->{'_FocusOut'}{$w}->Call; - delete $t->{'_focus'}; - } -} - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm deleted file mode 100644 index e94c037e6fe..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm +++ /dev/null @@ -1,1510 +0,0 @@ -# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Widget; -use vars qw($VERSION @DefaultMenuLabels); -$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/; - -require Tk; -use AutoLoader; -use strict; -use Carp; -use base qw(DynaLoader Tk); - -# stubs for 'autoloaded' widget classes -sub Button; -sub Canvas; -sub Checkbutton; -sub Entry; -sub Frame; -sub Label; -sub Labelframe; -sub Listbox; -sub Menu; -sub Menubutton; -sub Message; -sub Panedwindow; -sub Radiobutton; -sub Scale; -sub Scrollbar; -sub Spinbox; -sub Text; -sub Toplevel; - -sub Pixmap; -sub Bitmap; -sub Photo; - -sub ScrlListbox; -sub Optionmenu; - -sub import -{ - my $package = shift; - carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_); - my $need; - foreach $need (@_) - { - unless (defined &{$need}) - { - require "Tk/${need}.pm"; - } - croak "Cannot locate $need" unless (defined &{$need}); - } -} - -@DefaultMenuLabels = qw[~File ~Help]; - -# Some tidy-ness functions for winfo stuff - -sub True { 1 } -sub False { 0 } - -use Tk::Submethods( 'grab' => [qw(current status release -global)], - 'focus' => [qw(-force -lastfor)], - 'pack' => [qw(configure forget info propagate slaves)], - 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)], - 'form' => [qw(check configure forget grid info slaves)], - 'event' => [qw(add delete generate info)], - 'place' => [qw(configure forget info slaves)], - 'wm' => [qw(capture release)], - 'font' => [qw(actual configure create delete families measure metrics names subfonts)] - ); - -BEGIN { - # FIXME - these don't work in the compiler - *IsMenu = \&False; - *IsMenubutton = \&False; - *configure_self = \&Tk::configure; - *cget_self = \&Tk::cget; -} - - - -Direct Tk::Submethods ( - 'winfo' => [qw(cells class colormapfull depth exists - geometry height id ismapped manager name parent reqheight - reqwidth rootx rooty screen screencells screendepth screenheight - screenmmheight screenmmwidth screenvisual screenwidth visual - visualsavailable vrootheight viewable vrootwidth vrootx vrooty - width x y toplevel children pixels pointerx pointery pointerxy - server fpixels rgb )], - 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]); - - -sub DESTROY -{ - my $w = shift; - $w->destroy if ($w->IsWidget); -} - -sub Install -{ - # Dynamically loaded widgets add their core commands - # to the Tk base class here - my ($package,$mw) = @_; -} - -sub ClassInit -{ - # Carry out class bindings (or whatever) - my ($package,$mw) = @_; - return $package; -} - -sub CreateOptions -{ - return (); -} - -sub CreateArgs -{ - my ($package,$parent,$args) = @_; - # Remove from hash %$args any configure-like - # options which only apply at create time (e.g. -colormap for Frame), - # or which may as well be applied right away - # return these as a list of -key => value pairs - # Augment same hash with default values for missing mandatory options, - # allthough this can be done later in InitObject. - - # Honour -class => if present, we have hacked Tk_ConfigureWidget to - # allow -class to be passed to any widget. - my @result = (); - my $class = delete $args->{'-class'}; - ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class); - @result = (-class => "\u$class") if (defined $class); - foreach my $opt ($package->CreateOptions) - { - push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt}; - } - return @result; -} - -sub InitObject -{ - my ($obj,$args) = @_; - # per object initialization, for example populating - # with sub-widgets, adding a few object bindings to augment - # inherited class bindings, changing binding tags. - # Also another chance to mess with %$args before configure... -} - -sub SetBindtags -{ - my ($obj) = @_; - $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']); -} - -sub new -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $package = shift; - my $parent = shift; - $package->InitClass($parent); - $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0); - my %args = @_; - my @args = $package->CreateArgs($parent,\%args); - my $cmd = $package->Tk_cmd; - my $pname = $parent->PathName; - $pname = '' if ($pname eq '.'); - my $leaf = delete $args{'Name'}; - if (defined $leaf) - { - $leaf =~ s/[^a-z0-9_#]+/_/ig; - $leaf = lcfirst($leaf); - } - else - { - ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/; - } - my $lname = $pname . '.' . $leaf; - # create a hash indexed by leaf name to speed up - # creation of a lot of sub-widgets of the same type - # e.g. entries in Table - my $nhash = $parent->TkHash('_names_'); - $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf}); - while (defined ($parent->Widget($lname))) - { - $lname = $pname . '.' . $leaf . ++$nhash->{$leaf}; - } - my $obj = eval { &$cmd($parent, $lname, @args) }; - confess $@ if $@; - unless (ref $obj) - { - die "No value from $cmd $lname" unless defined $obj; - warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname; - $obj = $parent->Widget($lname = $obj); - die "$obj from $lname" unless ref $obj; - } - bless $obj,$package; - $obj->SetBindtags; - my $notice = $parent->can('NoticeChild'); - $parent->$notice($obj,\%args) if $notice; - $obj->InitObject(\%args); -# ASkludge(\%args,1); - $obj->configure(%args) if (%args); -# ASkludge(\%args,0); - return $obj; -} - -sub DelegateFor -{ - my ($w,$method) = @_; - while(exists $w->{'Delegates'}) - { - my $delegate = $w->{'Delegates'}; - my $widget = $delegate->{$method}; - $widget = $delegate->{DEFAULT} unless (defined $widget); - $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget); - last unless (defined $widget); - last if $widget == $w; - $w = $widget; - } - return $w; -} - -sub Delegates -{ - my $cw = shift; - my $specs = $cw->TkHash('Delegates'); - while (@_) - { - my $key = shift; - my $val = shift; - $specs->{$key} = $val; - } - return $specs; -} - -sub Construct -{ - my ($base,$name) = @_; - my $class = (caller(0))[0]; - no strict 'refs'; - - # Hack for broken ->isa in perl5.6.0 - delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; - - # Pre ->isa scheme - *{$base.'::Is'.$name} = \&False; - *{$class.'::Is'.$name} = \&True; - - # DelegateFor trickyness is to allow Frames and other derived things - # to force creation in a delegate e.g. a ScrlText with embeded windows - # need those windows to be children of the Text to get clipping right - # and not of the Frame which contains the Text and the scrollbars. - *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) }; -} - -sub IS -{ - return (defined $_[1]) && $_[0] == $_[1]; -} - -sub _AutoloadTkWidget -{ - my ($self,$method) = @_; - my $what = "Tk::Widget::$method"; - unless (defined &$what) - { - require "Tk/$method.pm"; - } - return $what; -} - -# require UNIVERSAL; don't load .pm use XS code from perl core though - -sub AUTOLOAD -{ - # Take a copy into a 'my' variable so we can recurse - my $what = $Tk::Widget::AUTOLOAD; - my $save = $@; - my $name; - # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; - # Braces used to preserve $1 et al. - { - my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; - confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/; - $pkg =~ s#::#/#g; - if (defined($name=$INC{"$pkg.pm"})) - { - $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; - } - else - { - $name = "auto/$what.al"; - $name =~ s#::#/#g; - } - } - # This may fail, catch error and prevent user's __DIE__ handler - # from triggering as well... - eval {local $SIG{'__DIE__'}; require $name}; - if ($@) - { - croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); - my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); - if (ref $_[0] && !$_[0]->can($method) - && $_[0]->can('Delegate') - && $method !~ /^(ConfigSpecs|Delegates)/ ) - { - my $delegate = $_[0]->Delegates; - if (%$delegate || tied %$delegate) - { - my $widget = $delegate->{$method}; - $widget = $delegate->{DEFAULT} unless (defined $widget); - if (defined $widget) - { - my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget); - if (defined $subwidget) - { - no strict 'refs'; - # print "AUTOLOAD: $what\n"; - *{$what} = sub { shift->Delegate($method,@_) }; - } - else - { - croak "No delegate subwidget '$widget' for $what"; - } - } - } - } - if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/) - { - # Use ->can as ->isa is broken in perl5.6.0 - my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget'); - if ($sub) - { - carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method); - $what = $_[0]->$sub($method) - } - } - } - $@ = $save; - $DB::sub = $what; # Tell debugger what is going on... - unless (defined &$what) - { - no strict 'refs'; - *{$what} = sub { croak("Failed to AUTOLOAD '$what'") }; - } - goto &$what; -} - -sub _Destroyed -{ - my $w = shift; - my $a = delete $w->{'_Destroy_'}; - if (ref($a)) - { - while (@$a) - { - my $ent = pop(@$a); - if (ref $ent) - { - eval {local $SIG{'__DIE__'}; $ent->Call }; - } - else - { - delete $w->{$ent}; - } - } - } -} - -sub _OnDestroy -{ - my $w = shift; - $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'}); - push(@{$w->{'_Destroy_'}},@_); -} - -sub OnDestroy -{ - my $w = shift; - $w->_OnDestroy(Tk::Callback->new(@_)); -} - -sub TkHash -{ - my ($w,$key) = @_; - return $w->{$key} if exists $w->{$key}; - my $hash = $w->{$key} = {}; - $w->_OnDestroy($key); - return $hash; -} - -sub privateData -{ - my $w = shift; - my $p = shift || caller; - $w->{$p} ||= {}; -} - -my @image_types; -my %image_method; - -sub ImageMethod -{ - shift if (@_ & 1); - while (@_) - { - my ($name,$method) = splice(@_,0,2); - push(@image_types,$name); - $image_method{$name} = $method; - } -} - -sub Getimage -{ - my ($w, $name) = @_; - my $mw = $w->MainWindow; - croak "Usage \$widget->Getimage('name')" unless defined($name); - my $images = ($mw->{'__Images__'} ||= {}); - - return $images->{$name} if $images->{$name}; - - ImageMethod(xpm => 'Pixmap', - gif => 'Photo', - ppm => 'Photo', - xbm => 'Bitmap' ) unless @image_types; - - foreach my $type (@image_types) - { - my $method = $image_method{$type}; - my $file = Tk->findINC( "$name.$type" ); - next unless( $file && $method ); - my $sub = $w->can($method); - unless (defined &$sub) - { - require Tk::widgets; - Tk::widgets->import($method); - } - $images->{$name} = $w->$method( -file => $file ); - return $images->{$name}; - } - - # Try built-in bitmaps - $images->{$name} = $w->Pixmap( -id => $name ); - return $images->{$name}; -} - -sub SaveGrabInfo -{ - my $w = shift; - $Tk::oldGrab = $w->grabCurrent; - if (defined $Tk::oldGrab) - { - $Tk::grabStatus = $Tk::oldGrab->grabStatus; - } -} - -sub grabSave -{ - my ($w) = @_; - my $grab = $w->grabCurrent; - return sub {} if (!defined $grab); - my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab'; - return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } }; -} - -sub focusCurrent -{ - my ($w) = @_; - $w->Tk::focus('-displayof'); -} - -sub focusSave -{ - my ($w) = @_; - my $focus = $w->focusCurrent; - return sub {} if (!defined $focus); - return sub { eval {local $SIG{'__DIE__'}; $focus->focus } }; -} - -# This is supposed to replicate Tk::after behaviour, -# but does auto-cancel when widget is deleted. -require Tk::After; - -sub afterCancel -{ - my ($w,$what) = @_; - if (defined $what) - { - return $what->cancel if ref($what); - carp "dubious cancel of $what" if 0 && $^W; - $w->Tk::after('cancel' => $what); - } -} - -sub afterIdle -{ - my $w = shift; - return Tk::After->new($w,'idle','once',@_); -} - -sub afterInfo { - my ($w, $id) = @_; - if (defined $id) { - return ($id->[4], $id->[2], $id->[3]); - } else { - return sort( keys %{$w->{_After_}} ); - } -} - -sub after -{ - my $w = shift; - my $t = shift; - if (@_) - { - if ($t ne 'cancel') - { - require Tk::After; - return Tk::After->new($w,$t,'once',@_) - } - while (@_) - { - my $what = shift; - $w->afterCancel($what); - } - } - else - { - $w->Tk::after($t); - } -} - -sub repeat -{ - require Tk::After; - my $w = shift; - my $t = shift; - return Tk::After->new($w,$t,'repeat',@_); -} - -sub FindMenu -{ - # default FindMenu is that there is no menu. - return undef; -} - -sub XEvent { shift->{'_XEvent_'} } - -sub propertyRoot -{ - my $w = shift; - return $w->property(@_,'root'); -} - -# atom, atomname, containing, interps, pathname -# don't work this way - there is no window arg -# So we pretend there was an call the C versions from Tk.xs - -sub atom { shift->InternAtom(@_) } -sub atomname { shift->GetAtomName(@_) } -sub containing { shift->Containing(@_) } - -# interps not done yet -# pathname not done yet - -# walk and descendants adapted from Stephen's composite -# versions as they only use core features they can go here. -# hierachy is reversed in that descendants calls walk rather -# than vice versa as this avoids building a list. -# Walk should possibly be enhanced so allow early termination -# like '-prune' of find. - -sub Walk -{ - # Traverse a widget hierarchy while executing a subroutine. - my($cw, $proc, @args) = @_; - my $subwidget; - foreach $subwidget ($cw->children) - { - $subwidget->Walk($proc,@args); - &$proc($subwidget, @args); - } -} # end walk - -sub Descendants -{ - # Return a list of widgets derived from a parent widget and all its - # descendants of a particular class. - # If class is not passed returns the entire widget hierarchy. - - my($widget, $class) = @_; - my(@widget_tree) = (); - - $widget->Walk( - sub { my ($widget,$list,$class) = @_; - push(@$list, $widget) if (!defined($class) or $class eq $widget->class); - }, - \@widget_tree, $class - ); - return @widget_tree; -} - -sub Palette -{ - my $w = shift->MainWindow; - unless (exists $w->{_Palette_}) - { - my %Palette = (); - my $c = $w->Checkbutton(); - my $e = $w->Entry(); - my $s = $w->Scrollbar(); - $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ; - $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3]; - $Palette{'background'} = ($c->configure('-background'))[3]; - $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3]; - $Palette{'foreground'} = ($c->configure('-foreground'))[3]; - $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3]; - $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3]; - $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3]; - $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3]; - $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3]; - $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3]; - $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3]; - $c->destroy; - $e->destroy; - $s->destroy; - $w->{_Palette_} = \%Palette; - } - return $w->{_Palette_}; -} - -# tk_setPalette -- -# Changes the default color scheme for a Tk application by setting -# default colors in the option database and by modifying all of the -# color options for existing widgets that have the default value. -# -# Arguments: -# The arguments consist of either a single color name, which -# will be used as the new background color (all other colors will -# be computed from this) or an even number of values consisting of -# option names and values. The name for an option is the one used -# for the option database, such as activeForeground, not -activeforeground. -sub setPalette -{ - my $w = shift->MainWindow; - my %new = (@_ == 1) ? (background => $_[0]) : @_; - my $priority = delete($new{'priority'}) || 'widgetDefault'; - - # Create an array that has the complete new palette. If some colors - # aren't specified, compute them from other colors that are specified. - - die 'must specify a background color' if (!exists $new{background}); - $new{'foreground'} = 'black' unless (exists $new{foreground}); - my @bg = $w->rgb($new{'background'}); - my @fg = $w->rgb($new{'foreground'}); - my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560); - foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor') - { - $new{$i} = $new{'foreground'} unless (exists $new{$i}); - } - unless (exists $new{'disabledForeground'}) - { - $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024); - } - $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'}); - - unless (exists $new{'activeBackground'}) - { - my @light; - # Pick a default active background that is lighter than the - # normal background. To do this, round each color component - # up by 15% or 1/3 of the way to full white, whichever is - # greater. - foreach my $i (0, 1, 2) - { - $light[$i] = $bg[$i]/256; - my $inc1 = $light[$i]*15/100; - my $inc2 = (255-$light[$i])/3; - if ($inc1 > $inc2) - { - $light[$i] += $inc1 - } - else - { - $light[$i] += $inc2 - } - $light[$i] = 255 if ($light[$i] > 255); - } - $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light); - } - $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'}); - $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'}); - $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'}); - - # Before doing this, make sure that the Tk::Palette variable holds - # the default values of all options, so that tkRecolorTree can - # be sure to only change options that have their default values. - # If the variable exists, then it is already correct (it was created - # the last time this procedure was invoked). If the variable - # doesn't exist, fill it in using the defaults from a few widgets. - my $Palette = $w->Palette; - - # Walk the widget hierarchy, recoloring all existing windows. - $w->RecolorTree(\%new); - # Change the option database so that future windows will get the - # same colors. - foreach my $option (keys %new) - { - $w->option('add',"*$option",$new{$option},$priority); - # Save the options in the global variable Tk::Palette, for use the - # next time we change the options. - $Palette->{$option} = $new{$option}; - } -} - -# tkRecolorTree -- -# This procedure changes the colors in a window and all of its -# descendants, according to information provided by the colors -# argument. It only modifies colors that have their default values -# as specified by the Tk::Palette variable. -# -# Arguments: -# w - The name of a window. This window and all its -# descendants are recolored. -# colors - The name of an array variable in the caller, -# which contains color information. Each element -# is named after a widget configuration option, and -# each value is the value for that option. -sub RecolorTree -{ - my ($w,$colors) = @_; - local ($@); - my $Palette = $w->Palette; - foreach my $dbOption (keys %$colors) - { - my $option = "-\L$dbOption"; - my $value; - eval {local $SIG{'__DIE__'}; $value = $w->cget($option) }; - if (defined $value) - { - if ($value eq $Palette->{$dbOption}) - { - $w->configure($option,$colors->{$dbOption}); - } - } - } - foreach my $child ($w->children) - { - $child->RecolorTree($colors); - } -} -# tkDarken -- -# Given a color name, computes a new color value that darkens (or -# brightens) the given color by a given percent. -# -# Arguments: -# color - Name of starting color. -# perecent - Integer telling how much to brighten or darken as a -# percent: 50 means darken by 50%, 110 means brighten -# by 10%. -sub Darken -{ - my ($w,$color,$percent) = @_; - my @l = $w->rgb($color); - my $red = $l[0]/256; - my $green = $l[1]/256; - my $blue = $l[2]/256; - $red = int($red*$percent/100); - $red = 255 if ($red > 255); - $green = int($green*$percent/100); - $green = 255 if ($green > 255); - $blue = int($blue*$percent/100); - $blue = 255 if ($blue > 255); - sprintf('#%02x%02x%02x',$red,$green,$blue) -} -# tk_bisque -- -# Reset the Tk color palette to the old "bisque" colors. -# -# Arguments: -# None. -sub bisque -{ - shift->setPalette('activeBackground' => '#e6ceb1', - 'activeForeground' => 'black', - 'background' => '#ffe4c4', - 'disabledForeground' => '#b0b0b0', - 'foreground' => 'black', - 'highlightBackground' => '#ffe4c4', - 'highlightColor' => 'black', - 'insertBackground' => 'black', - 'selectColor' => '#b03060', - 'selectBackground' => '#e6ceb1', - 'selectForeground' => 'black', - 'troughColor' => '#cdb79e' - ); -} - -sub PrintConfig -{ - require Tk::Pretty; - my ($w) = (@_); - my $c; - foreach $c ($w->configure) - { - print Tk::Pretty::Pretty(@$c),"\n"; - } -} - -sub BusyRecurse -{ - my ($restore,$w,$cursor,$recurse,$top) = @_; - my $c = $w->cget('-cursor'); - my @tags = $w->bindtags; - if ($top || defined($c)) - { - push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) }); - $w->configure(-cursor => $cursor); - } - else - { - push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) }); - } - $w->bindtags(['Busy',@tags]); - if ($recurse) - { - foreach my $child ($w->children) - { - BusyRecurse($restore,$child,$cursor,1,0); - } - } - return $restore; -} - -sub Busy -{ - my ($w,@args) = @_; - return unless $w->viewable; - my($sub, %args); - for(my $i=0; $i<=$#args; $i++) - { - if (ref $args[$i] eq 'CODE') - { - if (defined $sub) - { - croak "Multiple code definitions not allowed in Tk::Widget::Busy"; - } - $sub = $args[$i]; - } - else - { - $args{$args[$i]} = $args[$i+1]; $i++; - } - } - my $cursor = delete $args{'-cursor'}; - my $recurse = delete $args{'-recurse'}; - $cursor = 'watch' unless defined $cursor; - unless (exists $w->{'Busy'}) - { - my @old = ($w->grabSave); - my $key; - my @config; - foreach $key (keys %args) - { - push(@config,$key => $w->Tk::cget($key)); - } - if (@config) - { - push(@old, sub { $w->Tk::configure(@config) }); - $w->Tk::configure(%args); - } - unless ($w->Tk::bind('Busy')) - { - $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]); - $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]); - $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]); - $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]); - $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]); - } - $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1); - } - my $g = $w->grabCurrent; - if (defined $g) - { - # warn "$g has the grab"; - $g->grabRelease; - } - $w->update; - eval {local $SIG{'__DIE__'}; $w->grab }; - $w->update; - if ($sub) - { - eval { $sub->() }; - my $err = $@; - $w->Unbusy(-recurse => $recurse); - die $err if $err; - } -} - -sub _busy -{ - my ($w,$f) = @_; - $w->bell if $f; - $w->break; -} - -sub Unbusy -{ - my ($w) = @_; - $w->update; - $w->grabRelease if Tk::Exists($w); - my $old = delete $w->{'Busy'}; - if (defined $old) - { - local $SIG{'__DIE__'}; - eval { &{pop(@$old)} } while (@$old); - } - $w->update if Tk::Exists($w); -} - -sub waitVisibility -{ - my ($w) = shift; - $w->tkwait('visibility',$w); -} - -sub waitVariable -{ - my ($w) = shift; - $w->tkwait('variable',@_); -} - -sub waitWindow -{ - my ($w) = shift; - $w->tkwait('window',$w); -} - -sub EventWidget -{ - my ($w) = @_; - return $w->{'_EventWidget_'}; -} - -sub Popwidget -{ - my ($ew,$method,$w,@args) = @_; - $w->{'_EventWidget_'} = $ew; - $w->$method(@args); -} - -sub ColorOptions -{ - my ($w,$args) = @_; - my $opt; - $args = {} unless (defined $args); - foreach $opt (qw(-foreground -background -disabledforeground - -activebackground -activeforeground - )) - { - $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt}) - } - return (wantarray) ? %$args : $args; -} - -sub XscrollBind -{ - my ($mw,$class) = @_; - $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']); - $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); - $mw->bind($class,'<Right>', ['xview','scroll',1,'units']); - $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']); - $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']); - - $mw->bind($class,'<Home>', ['xview','moveto',0]); - $mw->bind($class,'<End>', ['xview','moveto',1]); - $mw->XMouseWheelBind($class); -} - -sub PriorNextBind -{ - my ($mw,$class) = @_; - $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']); - $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']); -} - -sub XMouseWheelBind -{ - my ($mw,$class) = @_; - # <4> and <5> are how mousewheel looks on X - # <4> and <5> are how mousewheel looks on X - $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']); - $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']); -} - -sub YMouseWheelBind -{ - my ($mw,$class) = @_; - # <4> and <5> are how mousewheel looks on X - $mw->bind($class,'<4>', ['yview','scroll',-1,'units']); - $mw->bind($class,'<5>', ['yview','scroll',1,'units']); -} - -sub YscrollBind -{ - my ($mw,$class) = @_; - $mw->PriorNextBind($class); - $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']); - $mw->bind($class,'<Down>', ['yview','scroll',1,'units']); - $mw->YMouseWheelBind($class); -} - -sub XYscrollBind -{ - my ($mw,$class) = @_; - $mw->YscrollBind($class); - $mw->XscrollBind($class); - # <4> and <5> are how mousewheel looks on X -} - -sub MouseWheelBind -{ - my($mw,$class) = @_; - - # The MouseWheel will typically only fire on Windows. However, one - # could use the "event generate" command to produce MouseWheel - # events on other platforms. - - $mw->Tk::bind($class, '<MouseWheel>', - [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); - - if ($Tk::platform eq 'unix') - { - # Support for mousewheels on Linux/Unix commonly comes through mapping - # the wheel to the extended buttons. If you have a mousewheel, find - # Linux configuration info at: - # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ - $mw->Tk::bind($class, '<4>', - sub { $_[0]->yview('scroll', -3, 'units') - unless $Tk::strictMotif; - }); - $mw->Tk::bind($class, '<5>', - sub { $_[0]->yview('scroll', 3, 'units') - unless $Tk::strictMotif; - }); - } -} - -sub ScrlListbox -{ - my $parent = shift; - return $parent->Scrolled('Listbox',-scrollbars => 'w', @_); -} - -sub AddBindTag -{ - my ($w,$tag) = @_; - my $t; - my @tags = $w->bindtags; - foreach $t (@tags) - { - return if $t eq $tag; - } - $w->bindtags([@tags,$tag]); -} - -sub Callback -{ - my $w = shift; - my $name = shift; - my $cb = $w->cget($name); - if (defined $cb) - { - return $cb->Call(@_) if (ref $cb); - return $w->$cb(@_); - } - return (wantarray) ? () : undef; -} - -sub packAdjust -{ -# print 'packAdjust(',join(',',@_),")\n"; - require Tk::Adjuster; - my ($w,%args) = @_; - my $delay = delete($args{'-delay'}); - $delay = 1 unless (defined $delay); - $w->pack(%args); - %args = $w->packInfo; - my $adj = Tk::Adjuster->new($args{'-in'}, - -widget => $w, -delay => $delay, -side => $args{'-side'}); - $adj->packed($w,%args); - return $w; -} - -sub gridAdjust -{ - require Tk::Adjuster; - my ($w,%args) = @_; - my $delay = delete($args{'-delay'}); - $delay = 1 unless (defined $delay); - $w->grid(%args); - %args = $w->gridInfo; - my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay); - $adj->gridded($w,%args); - return $w; -} - -sub place -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x) - { - $w->Tk::place(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::place('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub pack -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x) - { - # maybe array/scalar context issue with slaves - $w->Tk::pack(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::pack('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub grid -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x) - { - my $opt = shift; - Tk::grid($opt,$w,@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - Tk::grid('configure',$w,@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub form -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x) - { - $w->Tk::form(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::form('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub Scrolled -{ - my ($parent,$kind,%args) = @_; - $kind = 'Pane' if $kind eq 'Frame'; - # Find args that are Frame create time args - my @args = Tk::Frame->CreateArgs($parent,\%args); - my $name = delete $args{'Name'}; - push(@args,'Name' => $name) if (defined $name); - my $cw = $parent->Frame(@args); - @args = (); - # Now remove any args that Frame can handle - foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) - { - push(@args,$k,delete($args{$k})) if (exists $args{$k}) - } - # Anything else must be for target widget - pass at widget create time - my $w = $cw->$kind(%args); - # Now re-set %args to be ones Frame can handle - %args = @args; - $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'], - '-background' => [$w,'background','Background'], - '-foreground' => [$w,'foreground','Foreground'], - ); - $cw->AddScrollbars($w); - $cw->Default("\L$kind" => $w); - $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w); - $cw->ConfigDefault(\%args); - $cw->configure(%args); - return $cw; -} - -sub Populate -{ - my ($cw,$args) = @_; -} - -sub ForwardEvent -{ - my $self = shift; - my $to = shift; - $to->PassEvent($self->XEvent); -} - -# Save / Return abstract event type as in Tix. -sub EventType -{ - my $w = shift; - $w->{'_EventType_'} = $_[0] if @_; - return $w->{'_EventType_'}; -} - -sub PostPopupMenu -{ - my ($w, $X, $Y) = @_; - if (@_ < 3) - { - my $e = $w->XEvent; - $X = $e->X; - $Y = $e->Y; - } - my $menu = $w->menu; - $menu->Post($X,$Y) if defined $menu; -} - -sub FillMenu -{ - my ($w,$menu,@labels) = @_; - foreach my $lab (@labels) - { - my $method = $lab.'MenuItems'; - $method =~ s/~//g; - $method =~ s/[\s-]+/_/g; - if ($w->can($method)) - { - $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method()); - } - } - return $menu; -} - -sub menu -{ - my ($w,$menu) = @_; - if (@_ > 1) - { - $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'}; - $w->{'_MENU_'} = $menu; - } - return unless defined wantarray; - unless (exists $w->{'_MENU_'}) - { - $w->_OnDestroy('_MENU_'); - $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0); - $w->FillMenu($menu,$w->MenuLabels); - } - return $w->{'_MENU_'}; -} - -sub MenuLabels -{ - return @DefaultMenuLabels; -} - -sub FileMenuItems -{ - my ($w) = @_; - return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]]; -} - -sub WmDeleteWindow -{ - shift->toplevel->WmDeleteWindow -} - -sub BalloonInfo -{ - my ($widget,$balloon,$X,$Y,@opt) = @_; - foreach my $opt (@opt) - { - my $info = $balloon->GetOption($opt,$widget); - return $info if defined $info; - } -} - -sub ConfigSpecs { - - my $w = shift; - - return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; - -} - -*GetSelection = - ($Tk::platform eq 'unix' - ? sub - { - my $w = shift; - my $sel = @_ ? shift : "PRIMARY"; - my $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING") - }; - if ($@) - { - $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel) - }; - if ($@) - { - die "could not find default selection"; - } - } - $txt; - } - : sub - { - my $w = shift; - my $sel = @_ ? shift : "PRIMARY"; - my $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel) - }; - if ($@) - { - die "could not find default selection"; - } - $txt; - } - ); - -1; -__END__ - -sub bindDump { - - # Dump lots of good binding information. This pretty-print subroutine - # is, essentially, the following code in disguise: - # - # print "Binding information for $w\n"; - # foreach my $tag ($w->bindtags) { - # printf "\n Binding tag '$tag' has these bindings:\n"; - # foreach my $binding ($w->bind($tag)) { - # printf " $binding\n"; - # } - # } - - my ($w) = @_; - - my (@bindtags) = $w->bindtags; - my $digits = length( scalar @bindtags ); - my ($spc1, $spc2) = ($digits + 33, $digits + 35); - my $format1 = "%${digits}d."; - my $format2 = ' ' x ($digits + 2); - my $n = 0; - - my @out; - push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w ); - - foreach my $tag (@bindtags) { - my (@bindings) = $w->bind($tag); - $n++; # count this bindtag - - if ($#bindings == -1) { - push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n ); - } else { - push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n ); - - foreach my $binding ( @bindings ) { - my $callback = $w->bind($tag, $binding); - push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback ); - - if ($callback =~ /SCALAR/) { - if (ref $$callback) { - push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback ); - } else { - push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback ); - } - } elsif ($callback =~ /ARRAY/) { - if (ref $callback->[0]) { - push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" ); - } else { - push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" ); - } - foreach my $arg (@$callback[1 .. $#{@$callback}]) { - if (ref $arg) { - push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg ); - } else { - push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg ); - } - - if (ref $arg eq 'Tk::Ev') { - if ($arg =~ /SCALAR/) { - push @out, sprintf( ": '$$arg'" ); - } else { - push @out, sprintf( ": '%s'", join("' '", @$arg) ); - } - } - - push @out, sprintf( "\n" ); - } # forend callback arguments - } # ifend callback - - } # forend all bindings for one tag - - } # ifend have bindings - - } # forend all tags - push @out, sprintf( "\n" ); - return @out; - -} # end bindDump - - -sub ASkludge -{ - my ($hash,$sense) = @_; - foreach my $key (%$hash) - { - if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR') - { - if ($sense) - { - my $val = ${$hash->{$key}}; - require Tie::Scalar; - tie ${$hash->{$key}},'Tie::StdScalar'; - ${$hash->{$key}} = $val; - } - else - { - untie ${$hash->{$key}}; - } - } - } -} - - - -# clipboardKeysyms -- -# This procedure is invoked to identify the keys that correspond to -# the "copy", "cut", and "paste" functions for the clipboard. -# -# Arguments: -# copy - Name of the key (keysym name plus modifiers, if any, -# such as "Meta-y") used for the copy operation. -# cut - Name of the key used for the cut operation. -# paste - Name of the key used for the paste operation. -# -# This method is obsolete use clipboardOperations and abstract -# event types instead. See Clipboard.pm and Mainwindow.pm - -sub clipboardKeysyms -{ - my @class = (); - my $mw = shift; - if (ref $mw) - { - $mw = $mw->DelegateFor('bind'); - } - else - { - push(@class,$mw); - $mw = shift; - } - if (@_) - { - my $copy = shift; - $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy); - } - if (@_) - { - my $cut = shift; - $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut); - } - if (@_) - { - my $paste = shift; - $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste); - } -} - -sub pathname -{ - my ($w,$id) = @_; - my $x = $w->winfo('pathname',-displayof => oct($id)); - return $x->PathName; -} diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm deleted file mode 100644 index ffbe4877857..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm +++ /dev/null @@ -1,174 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Wm; -use AutoLoader; - -require Tk::Widget; -*AUTOLOAD = \&Tk::Widget::AUTOLOAD; - -use strict qw(vars); - -# There are issues with this stuff now we have Tix's wm release/capture -# as toplevel-ness is now dynamic. - - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; - -use Tk::Submethods; - -*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) }; -*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) }; - -Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command - deiconify focusmodel frame geometry group - iconbitmap iconify iconimage iconmask iconname - iconwindow maxsize minsize overrideredirect positionfrom - protocol resizable sizefrom state title transient - withdraw wrapper)]); - -sub SetBindtags -{ - my ($obj) = @_; - $obj->bindtags([ref($obj),$obj,'all']); -} - -sub Populate -{ - my ($cw,$args) = @_; - $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef], - '-popanchor' => ['PASSIVE',undef,undef,undef], - '-popover' => ['PASSIVE',undef,undef,undef] - ); -} - -sub MoveResizeWindow -{ - my ($w,$x,$y,$width,$height) = @_; - $w->withdraw; - $w->geometry($width.'x'.$height); - $w->MoveToplevelWindow($x,$y); - $w->deiconify; -} - -sub WmDeleteWindow -{ - my ($w) = @_; - my $cb = $w->protocol('WM_DELETE_WINDOW'); - if (defined $cb) - { - $cb->Call; - } - else - { - $w->destroy; - } -} - - -1; - -__END__ - - -sub Post -{ - my ($w,$X,$Y) = @_; - $X = int($X); - $Y = int($Y); - $w->positionfrom('user'); - $w->geometry("+$X+$Y"); - # $w->MoveToplevelWindow($X,$Y); - $w->deiconify; - $w->raise; -} - -sub AnchorAdjust -{ - my ($anchor,$X,$Y,$w,$h) = @_; - $anchor = 'c' unless (defined $anchor); - $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; - $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; - return ($X,$Y); -} - -sub Popup -{ - my $w = shift; - $w->configure(@_) if @_; - $w->idletasks; - my ($mw,$mh) = ($w->reqwidth,$w->reqheight); - my ($rx,$ry,$rw,$rh) = (0,0,0,0); - my $base = $w->cget('-popover'); - my $outside = 0; - if (defined $base) - { - if ($base eq 'cursor') - { - ($rx,$ry) = $w->pointerxy; - } - else - { - $rx = $base->rootx; - $ry = $base->rooty; - $rw = $base->Width; - $rh = $base->Height; - } - } - else - { - my $sc = ($w->parent) ? $w->parent->toplevel : $w; - $rx = -$sc->vrootx; - $ry = -$sc->vrooty; - $rw = $w->screenwidth; - $rh = $w->screenheight; - } - my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); - ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); - # adjust to not cross screen borders - if ($X < 0) { $X = 0 } - if ($Y < 0) { $Y = 0 } - if ($mw > $w->screenwidth) { $X = 0 } - if ($mh > $w->screenheight) { $Y = 0 } - $w->Post($X,$Y); - $w->waitVisibility; -} - -sub FullScreen -{ - my $w = shift; - my $over = (@_) ? shift : 0; - my $width = $w->screenwidth; - my $height = $w->screenheight; - $w->GeometryRequest($width,$height); - $w->overrideredirect($over & 1); - $w->Post(0,0); - $w->update; - if ($over & 2) - { - my $x = $w->rootx; - my $y = $w->rooty; - $width -= 2*$x; - $height -= $x + $y; - $w->GeometryRequest($width,$height); - $w->update; - } -} - -sub iconposition -{ - my $w = shift; - if (@_ == 1) - { - return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; - if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) - { - my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; - my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; - return $w->wm('iconposition',$x,$y); - } - } - $w->wm('iconposition',@_); -} - |