package Tk::CmdLine;
use vars qw($VERSION);
$VERSION = '3.028'; # $Id: //depot/Tk8/Tk/CmdLine.pm#28 $
use 5.004;
use strict;
my$OBJECT=undef;
sub 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,resources=>{}};
return bless($self,$class);}sub Argument_{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_{my$self=shift(@_);
my($flag,$name)=@_;
my$val=$self->Argument_($flag);
push(@{$self->{command}},$flag,$val);
$self->{config}->{"-$name"}=$val;}sub Flag_{my$self=shift(@_);
my($flag,$name)=@_;
push(@{$self->{command}},$flag);
$self->{$name}=1;}sub Option_{my$self=shift(@_);
my($flag,$name)=@_;
my$val=$self->Argument_($flag);
push(@{$self->{command}},$flag,$val);
$self->{options}->{"*$name"}=$val;}sub Method_{my$self=shift(@_);
my($flag,$name)=@_;
my$val=$self->Argument_($flag);
push(@{$self->{command}},$flag,$val);
$self->{methods}->{$name}=$val;}sub Resource_{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',class=>'Config_',display=>'screen',fg=>'foreground',fn=>'font',font=>'Option_',foreground=>'Option_',geometry=>'Method_',iconic=>'Flag_',iconposition=>'Method_',motif=>'Flag_',name=>'Config_',screen=>'Config_',synchronous=>'Flag_',title=>'Config_',xrm=>'Resource_');
sub SetArguments{my$self=(@_?((ref($_[0])eq __PACKAGE__)?shift(@_):(($_[0]eq __PACKAGE__)?shift(@_):1)&&($OBJECT||=__PACKAGE__->new())):($OBJECT||=__PACKAGE__->new()));
$OBJECT=$self;
$self->{argv}=(@_?[@_]:\@ARGV);
$self->{offset}=0;
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){$self->{argv}->[$self->{offset}]=$option[1];}else{splice(@{$self->{argv}},$self->{offset},1);}$self->$method(('-'.$option[0]),$option[0]);}$self->{config}->{-class}||=ucfirst($self->{config}->{-name});
delete($self->{argv});
return$self;}use vars qw(&process);*process=\&SetArguments;
sub cget{my$self=(@_?((ref($_[0])eq __PACKAGE__)?shift(@_):(($_[0]eq __PACKAGE__)?shift(@_):1)&&($OBJECT||=__PACKAGE__->new())):($OBJECT||=__PACKAGE__->new()));
$OBJECT=$self;
my$option=shift(@_)||'-class';
$self->SetArguments()unless exists($self->{offset});
return(exists($self->{config}->{$option})?$self->{config}->{$option}:undef);}sub CreateArgs{my$self=(@_?((ref($_[0])eq __PACKAGE__)?shift(@_):(($_[0]eq __PACKAGE__)?shift(@_):1)&&($OBJECT||=__PACKAGE__->new())):($OBJECT||=__PACKAGE__->new()));
$OBJECT=$self;
$self->SetArguments()unless exists($self->{offset});
return$self->{config};}sub Tk::MainWindow::apply_command_line{my$mw=shift(@_);
my$self=($OBJECT||=__PACKAGE__->new());
$self->SetArguments()unless exists($self->{offset});
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};}$mw->Synchronize()if$self->{synchronous};
if($self->{iconic}){$mw->iconify();
$self->{iconic}=0;}$Tk::strictMotif=$self->{motif};
$mw->protocol('WM_SAVE_YOURSELF'=>['WMSaveYourself',$mw]);
$mw->command([$self->{name},@{$self->{command}}]);}sub SetResources{my$self=(@_?((ref($_[0])eq __PACKAGE__)?shift(@_):(($_[0]eq __PACKAGE__)?shift(@_):1)&&($OBJECT||=__PACKAGE__->new())):($OBJECT||=__PACKAGE__->new()));
$OBJECT=$self;
$self->SetArguments()unless exists($self->{offset});
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'){push(@{$self->{resources}->{$priority}},[@{$resource}])if(@{$resource}==2);}else{push(@{$self->{resources}->{$priority}},[$1,$2])if($resource=~/^([^!:\s]+)*\s*:\s*(.*)$/);}}return$self;}sub LoadResources{my$self=(@_?((ref($_[0])eq __PACKAGE__)?shift(@_):(($_[0]eq __PACKAGE__)?shift(@_):1)&&($OBJECT||=__PACKAGE__->new())):($OBJECT||=__PACKAGE__->new()));
$OBJECT=$self;
$self->SetArguments()unless exists($self->{offset});
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};}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'=>($ENV{LANG}||'C'),'%T'=>'app-defaults','%N'=>$self->{config}->{-class}};}my@postfix=map({$_.'/'.$self->{config}->{-class}}('/'.$self->{translation}->{'%L'}),'');
ITEM:foreach$fileSpec(split(':',$xpath)){if($fileSpec=~s/(%[A-Za-z])/$self->{translation}->{$1}/g){if(defined($echo)&&($file->{-symbol}ne 'XFILESEARCHPATH')){print$echo 'Checking ',$fileSpec,"\n";}next unless((-f$fileSpec)&&(-r _)&&(-s _));
$file->{-spec}=$fileSpec;
last;}else{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*$/);
next if($line=~/^\s*!/);
$continuation=($line=~s/\s*\\$/ /);
unless(defined($resource)){$resource=$line;}else{$line=~s/^\s*//;
$resource.=$line;}next if$continuation;
push(@resource,[$1,$2])if($resource=~/^([^:\s]+)*\s*:\s*(.*)$/);
$resource=undef;}close(SPEC);
if(defined($resource)){push(@resource,[$1,$2])if($resource=~/^([^:\s]+)*\s*:\s*(.*)$/);}$self->SetResources(\@resource,$file->{-priority})if@resource;}return$self;}1;
__END__

=cut
