diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/Tk/CmdLine.pm | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff) |
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/CmdLine.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/CmdLine.pm | 497 |
1 files changed, 0 insertions, 497 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm b/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm deleted file mode 100644 index ebe43a7f1e2..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/CmdLine.pm +++ /dev/null @@ -1,497 +0,0 @@ -package Tk::CmdLine; # -*-Perl-*- - -#/----------------------------------------------------------------------------// -#/ Module: Tk/CmdLine.pm -#/ -#/ Purpose: -#/ -#/ Process standard X11 command line options and set initial resources. -#/ -#/ Author: ???? Date: ???? -#/ -#/ History: SEE POD -#/----------------------------------------------------------------------------// - -use vars qw($VERSION); -$VERSION = '4.007'; # $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__ |