diff options
Diffstat (limited to 'Master/tlpkg/installer/perllib/Tk')
25 files changed, 5792 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/perllib/Tk/After.pm b/Master/tlpkg/installer/perllib/Tk/After.pm new file mode 100644 index 00000000000..85a0e406ee5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/After.pm @@ -0,0 +1,104 @@ +# 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/installer/perllib/Tk/Button.pm b/Master/tlpkg/installer/perllib/Tk/Button.pm new file mode 100644 index 00000000000..efa597dee14 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Button.pm @@ -0,0 +1,148 @@ +package Tk::Button; +# Conversion from Tk4.0 button.tcl competed. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-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/installer/perllib/Tk/Checkbutton.pm b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm new file mode 100644 index 00000000000..491d8cd2444 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm @@ -0,0 +1,42 @@ +package Tk::Checkbutton; +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-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/installer/perllib/Tk/Clipboard.pm b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm new file mode 100644 index 00000000000..b0eb0ea2b07 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm @@ -0,0 +1,122 @@ +# 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/installer/perllib/Tk/CmdLine.pm b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm new file mode 100644 index 00000000000..2e821e826ae --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm @@ -0,0 +1,954 @@ +package Tk::CmdLine; # -*-Perl-*- + +#/----------------------------------------------------------------------------// +#/ Module: Tk/CmdLine.pm +#/ +#/ Purpose: +#/ +#/ Process standard X11 command line options and set initial resources. +#/ +#/ Author: ???? Date: ???? +#/ +#/ History: SEE POD +#/----------------------------------------------------------------------------// + +use vars qw($VERSION); +$VERSION = '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/installer/perllib/Tk/Configure.pm b/Master/tlpkg/installer/perllib/Tk/Configure.pm new file mode 100644 index 00000000000..26252ae4958 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Configure.pm @@ -0,0 +1,69 @@ +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/installer/perllib/Tk/Derived.pm b/Master/tlpkg/installer/perllib/Tk/Derived.pm new file mode 100644 index 00000000000..c31c205d2fb --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Derived.pm @@ -0,0 +1,512 @@ +# 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/installer/perllib/Tk/Dialog.pm b/Master/tlpkg/installer/perllib/Tk/Dialog.pm new file mode 100644 index 00000000000..8173f4a5acc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Dialog.pm @@ -0,0 +1,70 @@ +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/installer/perllib/Tk/DialogBox.pm b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm new file mode 100644 index 00000000000..13335404e15 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm @@ -0,0 +1,135 @@ +# +# 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/installer/perllib/Tk/DummyEncode.pm b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm new file mode 100644 index 00000000000..5ead808405d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm @@ -0,0 +1,46 @@ +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/installer/perllib/Tk/Entry.pm b/Master/tlpkg/installer/perllib/Tk/Entry.pm new file mode 100644 index 00000000000..51b3f0c6767 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Entry.pm @@ -0,0 +1,615 @@ +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/installer/perllib/Tk/Event.pm b/Master/tlpkg/installer/perllib/Tk/Event.pm new file mode 100644 index 00000000000..cecd57c54ae --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Event.pm @@ -0,0 +1,13 @@ +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/installer/perllib/Tk/Event/IO.pm b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm new file mode 100644 index 00000000000..10b47e246ff --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm @@ -0,0 +1,132 @@ +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/installer/perllib/Tk/Frame.pm b/Master/tlpkg/installer/perllib/Tk/Frame.pm new file mode 100644 index 00000000000..a5716cdf9bd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Frame.pm @@ -0,0 +1,378 @@ +# 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/installer/perllib/Tk/Image.pm b/Master/tlpkg/installer/perllib/Tk/Image.pm new file mode 100644 index 00000000000..0f41c387fc2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Image.pm @@ -0,0 +1,74 @@ +# 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/installer/perllib/Tk/Label.pm b/Master/tlpkg/installer/perllib/Tk/Label.pm new file mode 100644 index 00000000000..ebea1741c2f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Label.pm @@ -0,0 +1,21 @@ +# 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/installer/perllib/Tk/MainWindow.pm b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm new file mode 100644 index 00000000000..5384ccb560b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm @@ -0,0 +1,213 @@ +# 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/installer/perllib/Tk/PNG.pm b/Master/tlpkg/installer/perllib/Tk/PNG.pm new file mode 100644 index 00000000000..1ecb4001d17 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/PNG.pm @@ -0,0 +1,43 @@ +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/installer/perllib/Tk/Photo.pm b/Master/tlpkg/installer/perllib/Tk/Photo.pm new file mode 100644 index 00000000000..a596dc4d78b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Photo.pm @@ -0,0 +1,22 @@ +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/installer/perllib/Tk/Pretty.pm b/Master/tlpkg/installer/perllib/Tk/Pretty.pm new file mode 100644 index 00000000000..7e442a4bcbc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Pretty.pm @@ -0,0 +1,93 @@ +# 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/installer/perllib/Tk/Radiobutton.pm b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm new file mode 100644 index 00000000000..d09d41b4208 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm @@ -0,0 +1,45 @@ +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-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/installer/perllib/Tk/Submethods.pm b/Master/tlpkg/installer/perllib/Tk/Submethods.pm new file mode 100644 index 00000000000..a2b8e3bd186 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Submethods.pm @@ -0,0 +1,46 @@ +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/installer/perllib/Tk/Toplevel.pm b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm new file mode 100644 index 00000000000..7bcd156d475 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm @@ -0,0 +1,211 @@ +# 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/installer/perllib/Tk/Widget.pm b/Master/tlpkg/installer/perllib/Tk/Widget.pm new file mode 100644 index 00000000000..e94c037e6fe --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Widget.pm @@ -0,0 +1,1510 @@ +# 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/installer/perllib/Tk/Wm.pm b/Master/tlpkg/installer/perllib/Tk/Wm.pm new file mode 100644 index 00000000000..ffbe4877857 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Wm.pm @@ -0,0 +1,174 @@ +# 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',@_); +} + |