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, " ...\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 --