Getopt-ExPar
view release on metacpan or search on metacpan
Getopt/ExPar.pm view on Meta::CPAN
package Getopt::ExPar;
$VERSION = "1.01";
# See the bottom of this file for the POD documentation. Search for the string '=head'.
use English;
use strict;
use warnings;
use Carp;
use vars qw(@ISA $VERSION);
@ISA = qw();
use AutoLoader ();
*AUTOLOAD = \&AutoLoader::AUTOLOAD;
# ExPar.pm - Extended Parameters
#
# Harlin L. Hamilton Jr. <mailto:harlinh@cadence.com>
#
# This package is free, and can be modified or redistributed under # the same terms as Perl itself.
#### Method: new
#######################################################################
# Contructor routine.
#######################################################################
sub _new {
my($class, $prefs) = @_;
#Initilize $self
my($self) = {};
$self->{'prefs'} = {
'ooRoutines' => 1,
'development_check' => 0,
'abbreviations' => 0,
'filelistpref' => -1,
'ignorecase' => 0,
'switchglomming' => 0,
'intermingledFiles' => 0,
};
$self->{'parameter'} = {};
$self->{'aliasnamehash'} = {};
#Overwrite elements in $self as specified by $prefs hash
&__parse_prefs($self, $prefs) if ((defined $prefs) and (ref($prefs) eq 'HASH'));
#Grab predefined types: integer, real, key, etc.
&__assert_predefined_types($self);
#Bless object into class and return
bless $self, $class;
}
#Preference methods
sub _ooRoutines {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'ooRoutines'} = $value;
} else {
return $self->{'prefs'}->{'ooRoutines'};
}
}
sub _development_check {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'development_check'} = $value;
} else {
return $self->{'prefs'}->{'development_check'};
}
}
sub _abbreviations {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'abbreviations'} = $value;
} else {
return $self->{'prefs'}->{'abbreviations'};
}
}
sub _filelistpref {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'filelistpref'} = $value;
} else {
return $self->{'prefs'}->{'filelistpref'};
}
}
sub _ignorecase {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'ignorecase'} = $value;
} else {
return $self->{'prefs'}->{'ignorecase'};
}
}
sub _switchglomming {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'switchglomming'} = $value;
} else {
return $self->{'prefs'}->{'switchglomming'};
}
}
sub _intermingledFiles {
my($self) = shift;
my($value) = shift;
if (defined $value) {
$self->{'prefs'}->{'intermingledFiles'} = $value;
} else {
return $self->{'prefs'}->{'intermingledFiles'};
}
}
#### Method: argl
############################################################################
#Routine to return the value (or the next value) of the specified parameter
############################################################################
sub _argl {
my($self) = shift;
my($parameter) = shift;
return undef unless (exists $self->{'OPT'}->{$parameter});
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
if (ref($self->{'OPT'}->{$parameter}) eq 'SCALAR') {
return $self->{'OPT'}->{$parameter};
} elsif (ref($self->{'OPT'}->{$parameter}) eq 'ARRAY') {
$self->{$pKind}->{$parameter}->{'cnt'} = 0
unless (exists $self->{$pKind}->{$parameter}->{'cnt'});
if ($self->{$pKind}->{$parameter}->{'cnt'} > $#{$self->{'OPT'}->{$parameter}}) {
return undef;
} elsif (@{$self->{'OPT'}->{$parameter}->[$self->{$pKind}->{$parameter}->{'cnt'}]} > 1) {
return $self->{'OPT'}->{$parameter}->[$self->{$pKind}->{$parameter}->{'cnt'}++];
} else {
return $self->{'OPT'}->{$parameter}->[$self->{$pKind}->{$parameter}->{'cnt'}++]->[0];
}
}
}
#### Method: arglprepare
############################################################################
#Routine to prepare for calling _argl
############################################################################
sub _arglprepare {
my($self) = shift;
my($parameter) = shift;
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
delete $self->{$pKind}->{$parameter}->{'cnt'};
}
#### Method: arg
############################################################################
#Routine to return the *first* value for specified parameter unless the
# parameter is a 'switch' then return the scalar value.
############################################################################
sub _arg {
my($self) = shift;
my($parameter) = shift;
return undef unless (exists $self->{'OPT'}->{$parameter});
if (ref($self->{'OPT'}->{$parameter}) ne 'ARRAY') {
return $self->{'OPT'}->{$parameter};
} else {
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
my($r) = [];
if ($pKind eq 'parameter') {
if (@{$self->{'OPT'}->{$parameter}->[0]} == 1) {
return $self->{'OPT'}->{$parameter}->[0]->[0];
} else {
return $self->{'OPT'}->{$parameter}->[0];
}
} else {
return $self->{'OPT'}->{$parameter}->[0];
Getopt/ExPar.pm view on Meta::CPAN
return $#{$self->{'OPT'}->{$parameter}}+1;
} else {
return $self->{'OPT'}->{$parameter};
}
} else {
return 0;
}
}
#### Method: arge/argt
############################################################################
#Routine to return 0/1 depending on existance of specified parameter.
# Or for special parameters, can check existance of a specific arg.
############################################################################
sub _arge { return &_argt(@_); }
sub _argt {
my($self) = shift;
my($parameter) = shift;
return 0 unless (exists $self->{'OPT'}->{$parameter});
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
if ($pKind eq 'parameter') {
return (exists $self->{'stats'}->{$parameter})? 1 : 0;
} else {
my($arg) = shift;
return (exists $self->{'OPT'}->{$parameter}) unless (defined $arg);
foreach my $a ( @{$self->{'OPT'}->{$parameter}} ) {
return 1 if ($a->[0] =~ /$arg/);
}
}
return 0;
}
#### Method: filelist/files
############################################################################
#Routine to return filelist if one exists
############################################################################
sub _files { return &_filelist(@_); }
sub _filelist {
my($self) = shift;
return undef unless (exists $self->{'OPT'}->{'filelist'});
return ($self->{'OPT'}->{'filelist'});
}
#### Method: parse
#######################################################################
#Routine to parse the command line options
#######################################################################
sub _parse {
my($self) = shift;
my($argv) = shift;
#Init some hashes
$self->{'OPT'} = {};
$self->{'stats'} = {};
$self->{'actions'}->{'help'} = 0;
#Parse @ARGV unless an array reference is passed in as second argument
$argv = \@ARGV unless ((defined $argv) and (ref($argv) eq 'ARRAY'));
#Do some development checking here
if ($self->{'prefs'}->{'development_check'}) {
#Check to make sure that a help_option value exists for all special parameters
my($str) = [];
foreach my $par ( keys %{$self->{'parameter'}} ) {
push(@{$str}, $par) unless (exists $self->{'parameter'}->{$par}->{'help'});
}
foreach my $spec ( keys %{$self->{'special'}} ) {
push(@{$str}, $spec) unless (exists $self->{'special'}->{$spec}->{'help'});
}
carp "Missing help text for these options: ", join(', ', sort @{$str}) if (@{$str} > 0);
$str = [];
foreach my $spec ( keys %{$self->{'special'}} ) {
push(@{$str}, $spec) unless (exists $self->{'special'}->{$spec}->{'help_option'});
}
carp "Missing help_option string for these special parameters: ", join(', ', sort @{$str}) if (@{$str} > 0);
}
#Very first thing is to check for '-help' options.
if (@{$argv} and ($argv->[0] eq '--help')) {
$self->{'actions'}->{'help'} = 1;
shift(@{$argv});
} elsif (@{$argv} and ($argv->[0] eq '--full_help')) {
$self->{'actions'}->{'help'} = 2;
shift(@{$argv});
#Check for first element of $argv for 'switchglomming'. To meet this criteria,
# the option must not match a defined parameter or alias, and it must not
# match an abbreviated option if 'abbreviations' is enabled.
#This 'if' statement also checks to make sure that the next command line argument
# starts with a '-', OR that trailing file names are permitted.
} elsif (($self->{'prefs'}->{'switchglomming'}) and
@{$argv} and ($argv->[0] =~ /^-([a-zA-Z0-9]+)$/) and
(($self->{'prefs'}->{'ignorecase'} and (not exists $self->{'parameter'}->{lc($1)})) or
(not exists $self->{'parameter'}->{$1})) and
(($self->{'prefs'}->{'ignorecase'} and (not exists $self->{'aliasnamehash'}->{lc($1)})) or
(not exists $self->{'aliasnamehash'}->{$1}))) {
#Now that we've checked to see if it's a defined parameter or an alias, we need to
# check to see if it's a match on a parameter abbreviation.
my(@abb);
if ($self->{'prefs'}->{'ignorecase'}) {
@abb = grep { /(?i)^$argv->[0]/ } keys %{$self->{'parameter'}};
} else {
@abb = grep { /^$argv->[0]/ } keys %{$self->{'parameter'}};
}
#Ok, now check to see if it's a valid 'switchglomming' parameter.
unless (($self->{'prefs'}->{'abbreviations'}) and @abb) {
$argv->[0] =~ /^-([a-zA-Z0-9]+)$/;
my($arg) = ($self->{'prefs'}->{'ignorecase'})? lc($1) : $1;
#This bit of code makes sure that each letter of the potential switchglom is
# a defined switch or alias for a swich. Actually, any user-defined type that has
# 0 arguments can be enabled through this switchglom mechanism.
my($sg) = {};
foreach ( split(//, $arg) ) {
if (exists $self->{'aliasnamehash'}->{$_}) {
$sg->{$_} = 1
if ($self->{'types'}->
{$self->{'parameter'}->{$self->{'aliasnamehash'}->{$_}}->{'type'}->[0]}->
{'number_of_arguments'} == 0);
} elsif (exists $self->{'parameter'}->{$_}) {
$sg->{$_} = 1
if ($self->{'types'}->
{$self->{'parameter'}->{$_}->{'type'}->[0]}->
{'number_of_arguments'} == 0);
}
}
if ((scalar keys %{$sg}) == length($arg)) {
foreach ( keys %{$sg} ) {
if ((exists $self->{'aliasnamehash'}->{$_}) or (exists $self->{'parameter'}->{$_})) {
delete $sg->{$_};
}
}
#If no keys left in %sg, then switchglomming found a successful match
if ((scalar keys %{$sg}) == 0) {
foreach my $switch ( split(//, $arg) ) {
if (exists $self->{'parameter'}->{$switch}) {
$self->{'OPT'}->{$switch} =
$self->{'types'}->{$self->{'parameter'}->{$switch}->{'type'}->[0]}->{'specifiedvalue'};
++$self->{'stats'}->{$switch};
} else {
$self->{'OPT'}->{$self->{'aliasnamehash'}->{$switch}} =
$self->{'types'}->{$self->{'parameter'}->{$self->{'aliasnamehash'}->{$switch}}->{'type'}->[0]}->{'specifiedvalue'};
++$self->{'stats'}->{$self->{'aliasnamehash'}->{$switch}};
}
}
shift(@{$argv}); #remove switchglom from command line argument list
}
}
}
}
#Loop through options and parse according to $self
my($i) = 0;
while ($i < @{$argv}) {
#Check for 'ignorecase'
my($cur_argv) = ($self->{'prefs'}->{'ignorecase'})? lc($argv->[$i]) : $argv->[$i];
#Parse option
my($origParameter) = $argv->[$i];
my($parameter) = $origParameter;
$parameter =~ s/^-//;
#At this point, determine the correctly capitalized parameter if ignorecase
if ($self->{'prefs'}->{'ignorecase'}) {
my($a) = [ grep { lc($parameter) eq lc($_) } keys %{$self->{'parameter'}} ];
if (@{$a} > 0) {
$parameter = $a->[0];
}
}
#Call help routine if $parameter is now '-help'
if ($parameter =~ /(?i)^\-?h(e(l(p)?)?)?$/) {
$self->{'actions'}->{'help'} = 1;
$i++;
next;
#Call full_help routine if $parameter is now '-help'
} elsif ($parameter =~ /(?i)^\-?full_h(e(l(p)?)?)?$/) {
$self->{'actions'}->{'help'} = 2;
$i++;
next;
}
#Store croak message
my($croak) = '';
#Make sure this option exists. First see if it's a defined parameter,
# then see if it's an alias, then see if it's an abbreviation.
if (not exists $self->{'parameter'}->{$parameter}) {
if (exists $self->{'aliasnamehash'}->{$parameter}) {
$parameter = $self->{'aliasnamehash'}->{$parameter};
} elsif ($self->{'prefs'}->{'abbreviations'}) {
my(@args) = grep { ($parameter =~ /^\W/)? /^\\$parameter/ : /^$parameter/ } keys %{$self->{'parameter'}};
if (@args == 1) {
if (exists $self->{'parameter'}->{$args[0]}) {
$parameter = $args[0];
} else {
$croak = "Unknown option (-$parameter)";
}
} elsif (@args == 0) {
$croak = "Unknown option (-$parameter)";
} elsif (@args > 1) {
$croak = "Ambiguous option (-$parameter) matches @args";
}
} else {
$croak = "Unknown option (-$parameter)";
}
}
if ( length($croak) ) {
undef $parameter;
#If $croak is not empty, then no match was found on parameters,
# so check special parameters.
if (exists $self->{'special'}) {
foreach my $sp ( keys %{$self->{'special'}} ) {
if (($cur_argv =~ /$self->{'special'}->{$sp}->{'special_pattern'}/) or
(($cur_argv =~ /(?i)$self->{'special'}->{$sp}->{'special_pattern'}/) and ($self->{'prefs'}->{'ignorecase'}))) {
$parameter = $sp;
last;
}
}
}
#When at this point, assume argument is a file
if (not defined $parameter) {
if ($argv->[$i] !~ /^-/) {
croak "File list not permitted (starting at '$argv->[$i]')"
unless (($self->{'prefs'}->{'filelist'} > -1) or ($self->{'prefs'}->{'intermingledFiles'} == 1));
if ($self->{'prefs'}->{'intermingledFiles'} == 1) {
push(@{$self->{'OPT'}->{'filelist'}}, $argv->[$i]);
++$i;
next;
} else {
push(@{$self->{'OPT'}->{'filelist'}}, @{$argv}[$i..$#{$argv}]);
last;
}
}
#Croak if $croak
croak $croak if length($croak);
}
}
#Determine parameter or special parameter
my($pKind) = (grep { exists $self->{$_}->{$parameter} } ('parameter', 'special',))[0];
#Handle argumentFile types here
if ($self->{$pKind}->{$parameter}->{'type'}->[0] eq 'argumentFile') {
my($file) = $argv->[$i+1];
my($pat) = (exists $self->{$pKind}->{$parameter}->{'argumentFileComment'})?
'(' . join('|', @{$self->{$pKind}->{$parameter}->{'argumentFileComment'}}) . ')' : '';
open(AF, "< $file") or croak "Unable to open file $file for reading.\n\n";
my($argStrArr) = [ 0 ];
while (<AF>) {
chomp;
s/$pat.*$// if length($pat);
next if /^\s*$/;
push(@{$argStrArr}, $_);
}
close AF;
my(@args) = `perl -e 'print join(\"\\n\", \@ARGV), \"\\n\";' @{$argStrArr}`;
chomp(@args);
splice(@{$argv}, $i, 2, @args);
splice(@{$argv}, $i, 1);
$i -= 2;
}
#Count parameter instances
++$self->{'stats'}->{$parameter};
#Assign value into $self->{'OPT'}:
#Handle special case of type that has no arguments (like type 'switch')
if ($self->{'types'}->{$self->{$pKind}->{$parameter}->{'type'}->[0]}->{'number_of_arguments'} == 0) {
if ($pKind eq 'parameter') {
$self->{'OPT'}->{$parameter} =
$self->{'types'}->{$self->{$pKind}->{$parameter}->{'type'}->[0]}->{'specifiedvalue'};
} else {
#since this is a 'special', check pattern and store $1 if it exists
$argv->[$i] =~ /$self->{'special'}->{$parameter}->{'special_pattern'}/;
if (defined $1) {
push(@{$self->{'OPT'}->{$parameter}}, [ $1 ]);
} else {
push(@{$self->{'OPT'}->{$parameter}}, [ $argv->[$i] ]);
}
}
} else {
my($args) = [];
foreach my $typeIndex ( 0 .. $#{$self->{$pKind}->{$parameter}->{'type'}} ) {
my($type) = $self->{$pKind}->{$parameter}->{'type'}->[$typeIndex];
croak "Not enough arguments for '$parameter'" unless ($i < $#{$argv});
Getopt/ExPar.pm view on Meta::CPAN
my($set) = [ grep { exists $self->{'stats'}->{$_} } @{$mutex} ];
croak "Invalid argument set. The following options are mutually exclusive: " .
join(', ', @{$set}) if (@{$set} > 1);
}
}
#Check for required arguments
foreach my $p ( keys %{$self->{'parameter'}} ) {
croak "Required parameter '$p' not specified"
if ($self->{'parameter'}->{$p}->{'required'} and (not exists $self->{'OPT'}->{$p}));
}
#Check for req_grps
if (exists $self->{'checks'}->{'req_grp'}) {
foreach my $req_grp ( @{$self->{'checks'}->{'req_grp'}} ) {
my($set) = [ grep { exists $self->{'stats'}->{$_} } @{$req_grp} ];
croak "Invalid argument set. The following options must be used together: " .
join(', ', @{$req_grp}) if ((@{$set} != 0) and (@{$set} != @{$req_grp}));
}
}
}
#Loop through all parameters to see if they've been defined, and if not,
# assign default values if they exist.
foreach my $p ( keys %{$self->{'parameter'}} ) {
next if (exists $self->{'OPT'}->{$p});
#Assign 'unspecified' values to any parameters w/ zero arguments that weren't specified
if ($self->{'types'}->{$self->{'parameter'}->{$p}->{'type'}->[0]}->{'number_of_arguments'} == 0) {
$self->{'OPT'}->{$p} = $self->{'types'}->{$self->{'parameter'}->{$p}->{'type'}->[0]}->{'unspecifiedvalue'};
} elsif ($self->{'types'}->{$self->{'parameter'}->{$p}->{'type'}->[0]}->{'number_of_arguments'} == 1) {
@{$self->{'OPT'}->{$p}} = @{$self->{'parameter'}->{$p}->{'default'}}
if (exists $self->{'parameter'}->{$p}->{'default'});
}
}
#If -help was specified, print help and quit
&__print_help($self, $argv, $self->{'actions'}->{'help'})
if ((exists $self->{'actions'}->{'help'}) and ($self->{'actions'}->{'help'} > 0));
}
#### Method: parameter
#######################################################################
# Routine to define a parameter
#######################################################################
sub _parameter {
my($self) = shift;
if (@_ == 1) {
if (ref($_[0]) eq 'HASH') {
foreach my $p ( keys %{$_[0]} ) {
&__assign_parameter($self, $p, $_[0]->{$p});
}
} else {
&__assign_parameter($self, $_[0], 'switch');
}
} elsif ($_[1] eq 'switches') {
foreach my $p ( split(//, $_[0]) ) {
&__assign_parameter($self, $p, 'switch');
}
#parameter properties passed in as a hash: { 'type' => 'integer', }
} elsif (ref($_[1]) eq 'HASH') {
#make sure type is specified in HASH
if ($self->{'prefs'}->{'development_check'}) {
croak "'type' must be specified in HASH passed to _parameter method"
unless ($_[1]->{'type'});
}
#do 'type' first, then do other properties ('default', 'alias', etc.)
&_type($self, $_[0], $_[1]->{'type'});
foreach my $prop ( grep { !/^type$/ } keys %{$_[1]} ) {
no strict 'refs';
&{"_$prop"}($self, $_[0], $_[1]->{$prop});
}
} else {
my($p) = shift;
my($t) = shift;
&__assign_parameter($self, $p, $t);
&_alias($self, $p, @_) if @_;
}
}
sub _p { &_parameter(@_); }
#### Method: required_parameter
#######################################################################
# Routine to define a required parameter
#######################################################################
sub _requiredParameter { &_required_parameter(@_); }
sub _required_parameter {
&_parameter(@_);
&_required(@_);
}
sub _reqp { &_required_parameter(@_); }
sub _rp { &_required_parameter(@_); }
#######################################################################
# Routine to define a type for a specified parameter
#######################################################################
sub _type { &__assign_parameter(@_); }
sub _t { &_type(@_); }
#######################################################################
# Routine to create hash for specified parameter
#######################################################################
sub __assign_parameter {
my($self, $parameter, $type) = @_;
if ($self->{'prefs'}->{'development_check'}) {
#Check to make sure that parameter is a scalar
croak "Inappropriate parameter identifier '$parameter'" if ref($parameter);
#Check to make sure that parameter of that same name doesn't already exit
croak "Multiply defined parameter '$parameter'"
if (exists $self->{'parameter'}->{$parameter});
#Check to make sure that the specified type exists
croak "Unknown type '$type' cannot be used by option '$parameter'"
unless (exists $self->{'types'}->{$type});
#Make sure parameter is not defined as an alias for an existing parameter
foreach my $a ( %{$self->{'aliasnamehash'}} ) {
croak "Invalid parameter '$parameter': already defined as an alias for '$self->{'aliasnamehash'}->{$parameter}'"
if (exists $self->{'aliasnamehash'}->{$parameter});
}
}
$self->{'parameter'}->{$parameter} = { 'type' => [$type], 'unique' => [0], };
$self->{'parameter'}->{$parameter}->{'required'} = 0;
$self->{'parameter'}->{$parameter}->{'unique'} = 0;
$self->{'parameter'}->{$parameter}->{'_ptype'} = 'single';
&__ooRoutines($self, $parameter);
}
#### Method: multi_parameter
#######################################################################
# Routine to define a parameter w/ multiple arguments
#######################################################################
sub _mp { &_multi_parameter(@_); }
sub _multiParameter { &_multi_parameter(@_); }
sub _multi_parameter {
my($self) = shift;
my($parameter) = shift;
if ($self->{'prefs'}->{'development_check'}) {
carp "Calling multi_parameter w/ only one named subparameter" if (@_ == 1);
}
$self->{'parameter'}->{$parameter}->{'required'} = 0;
$self->{'parameter'}->{$parameter}->{'unique'} = 0;
$self->{'parameter'}->{$parameter}->{'_ptype'} = 'multi';
foreach my $mp ( @_ ) {
croak "Call to multi_parameter must have HASH references as arguments"
unless (ref($mp) eq 'HASH');
croak "Call to multi_parameter must have HASH references w/ only one key"
unless ((scalar keys %{$mp}) == 1);
my($name) = (keys %{$mp})[0];
my($type) = $mp->{$name};
if ($self->{'prefs'}->{'development_check'}) {
croak "Multiply defined subparameter '$name' in declaration of '$parameter'"
if (exists $self->{'parameter'}->{$parameter}->{'nameOrder'}->{$name});
croak "Unknown type '$type' cannot be used by option '$parameter:$name'"
unless (exists $self->{'types'}->{$type});
}
push(@{$self->{'parameter'}->{$parameter}->{'type'}}, $type);
push(@{$self->{'parameter'}->{$parameter}->{'name'}}, $name);
$self->{'parameter'}->{$parameter}->{'nameOrder'}->{$name} =
$#{$self->{'parameter'}->{$parameter}->{'name'}};
}
&__ooRoutines($self, $parameter);
}
#### Method: required_multi_parameter
#######################################################################
# Routine to define a required multi parameter
#######################################################################
sub _requiredMultiParameter { &_required_multi_parameter(@_); }
sub _required_multi_parameter {
&_multi_parameter(@_);
&_required(@_);
}
sub _rmp { &_required_multi_parameter(@_); }
#### Method: multi_special
#######################################################################
# Routine to define a special w/ multiple arguments
#######################################################################
sub _multiSpecial { &_multi_special(@_); }
sub _multiSpecialParameter { &_multi_special_parameter(@_); }
sub _multi_special { &_multi_special_parameter(@_); }
sub _multi_special_parameter {
my($self) = shift;
my($special) = shift;
my($special_pattern) = shift;
if ($self->{'prefs'}->{'development_check'}) {
carp "Calling multi_special w/ only one named subparameter" if (@_ == 1);
}
$self->{'special'}->{$special}->{'required'} = 0;
foreach my $mp ( @_ ) {
croak "Call to multi_special must have HASH references as arguments"
unless (ref($mp) eq 'HASH');
croak "Call to multi_special must have HASH references w/ only one key"
unless ((scalar keys %{$mp}) == 1);
my($name) = (keys %{$mp})[0];
my($type) = $mp->{$name};
if ($self->{'prefs'}->{'development_check'}) {
croak "Multiply defined subparameter '$name' in declaration of '$special'"
if (exists $self->{'special'}->{$special}->{'nameOrder'}->{$name});
croak "Unknown type '$type' cannot be used by option '$special:$name'"
unless (exists $self->{'types'}->{$type});
}
push(@{$self->{'special'}->{$special}->{'type'}}, $type);
push(@{$self->{'special'}->{$special}->{'name'}}, $name);
$self->{'special'}->{$special}->{'nameOrder'}->{$name} =
$#{$self->{'special'}->{$special}->{'name'}};
}
$self->{'special'}->{$special}->{'special_pattern'} = $special_pattern;
&__ooRoutines($self, $special);
}
sub _ms { &_multi_special(@_); }
sub _msp { &_multi_special(@_); }
#### Method: special_parameter
#######################################################################
# Routine to define a special parameter
# sp(<name>, <pattern>)
# sp(<name>, <pattern>, <type>)
#######################################################################
sub _specialParameter { &_special_parameter(@_); }
sub _s { &_special_parameter(@_); }
sub _special { &_special_parameter(@_); }
sub _special_parameter {
my($self) = shift;
croak "Wrong number of arguments in method call" if ((@_ < 2) or (@_ > 3));
if (@_ == 2) {
&__assign_special_parameter($self, @_, 'switch');
} else {
&__assign_special_parameter($self, @_);
}
}
#######################################################################
# Routine to create hash for specified special parameter
#######################################################################
sub __assign_special_parameter {
my($self, $special, $pattern, $type) = @_;
if ($self->{'prefs'}->{'development_check'}) {
#Check to make sure that parameter of that same name doesn't already exit
croak "Multiply defined parameter '$special'"
if ((exists $self->{'special'}->{$special}) or
(exists $self->{'parameter'}->{$special}));
#Check to make sure that the specified type exists
croak "Unknown type '$type' cannot be used by option '$special'"
unless (exists $self->{'types'}->{$type});
}
$self->{'special'}->{$special}->{'required'} = 0;
$self->{'special'}->{$special}->{'unique'} = 0;
$self->{'special'}->{$special} = { 'special_pattern' => $pattern, 'type' => [ $type, ], };
&__ooRoutines($self, $special);
}
#### Method: alias
#######################################################################
#Routine to associate an alias of set of aliases w/ a parameter
#######################################################################
sub __ooRoutines {
my($self, $parameter) = @_;
if ($self->{'prefs'}->{'ooRoutines'}) {
my($code) = '';
$code = join('',
'sub ', (($parameter =~ /^\d/)? '_' : ''), $parameter,
' { my($self)=shift; return($self->_arg( \'', $parameter, '\', @_)); }', "\n",
map { join('',
'sub ', (($parameter =~ /^\d/)? '_' : ''), "${parameter}_$_",
' { my($self)=shift; return($self->_', $_, '( \'', $parameter, '\', @_)); }', "\n",) }
qw/arge argt args argv argl argc arglprepare argh/);
# print "$code\n\n";
eval "$code";
}
}
#### Method: alias
#######################################################################
#Routine to associate an alias of set of aliases w/ a parameter
#######################################################################
sub _a { &_alias(@_); }
sub _alias {
my($self) = shift;
my($parameter) = shift;
my(%a) = map { $_, 1 } @_;
if ($self->{'prefs'}->{'development_check'}) {
foreach my $a ( @_ ) {
croak "Alias '$a' specified for '$parameter' is already defined for '$self->{'aliasnamehash'}->{$a}'.\n"
if (exists $self->{'aliasnamehash'}->{$a});
}
}
foreach my $a ( @_ ) {
$self->{'parameter'}->{$parameter}->{'alias'}->{$a} = 1;
$self->{'aliasnamehash'}->{$a} = $parameter;
}
}
#### Method: keys
#######################################################################
#Routine to associate user-specified values w/ specified parameters
# keys( param, 0, 1, 2, 3 )
# keys( param, [ 0, 1, 2, 3 ] )
# keys( multiparam, [ 0, 1, 2 ], [ 4, 5, 6 ], [ 7, 8, 9 ] )
# keys( multiparam, { 'sub1' => [ 0, 1, 2 ], 'sub2' => [ 4, 5, 6 ], 'sub3' => [ 7, 8, 9 ] } )
#######################################################################
sub _key { &_keys(@_); }
sub _k { &_keys(@_); }
sub _keys {
my($self) = shift;
my($parameter) = shift;
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
if (@{$self->{$pKind}->{$parameter}->{'type'}} > 1) {
if (@_ > 1) {
$self->{$pKind}->{$parameter}->{'keys'} = \@_;
} elsif (ref($_[0]) eq 'HASH') {
if ($self->{'prefs'}->{'development_check'}) {
foreach ( keys %{$_[0]} ) {
croak "Subparameter $_ does not exist for $parameter"
unless (exists $self->{$pKind}->{$parameter}->{'nameOrder'}->{$_});
}
}
foreach ( keys %{$_[0]} ) {
$self->{$pKind}->{$parameter}->{'keys'}->[$self->{$pKind}->{$parameter}->{'nameOrder'}->{$_}] = $_[0]->{$_};
}
} else {
croak "Format of argument for _keys call is not valid.";
}
} else {
if (ref($_[0]) eq 'ARRAY') {
$self->{$pKind}->{$parameter}->{'keys'} = [ $_[0] ];
} else {
$self->{$pKind}->{$parameter}->{'keys'} = [ \@_ ];
}
}
}
#### Method: unique
#######################################################################
#Routine to mark parameters as unique
#######################################################################
sub _u { &_unique(@_); }
sub _unique {
my($self) = shift;
foreach my $p ( @_ ) {
my($pKind) = (exists $self->{'special'}->{$p})? 'special' : 'parameter';
$self->{$pKind}->{$p}->{'unique'} = 1;
}
}
#### Method: default
#######################################################################
#Routine to associate default values w/ specified parameters
# For p: $opt->d('p', 0, 1, 2, 3);
# For mp: $opt->d('p', [0, 1], [2, 3]);
#######################################################################
sub _d { &_default(@_); }
sub _default {
my($self) = shift;
my($parameter) = shift;
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
#Quick check for switch or switch-like type
croak "Default assignment of type '$self->{$pKind}->{$parameter}->{'type'}->[0]' makes no sense"
if ($self->{'types'}->{$self->{$pKind}->{$parameter}->{'type'}->[0]}->{'number_of_arguments'} == 0);
#Store default values
@{$self->{$pKind}->{$parameter}->{'default'}} = map { [ $_ ] } @_;
#Bulletproofing....do later (check default values for type matching, etc.
if ($self->{'prefs'}->{'development_check'}) {
}
}
#### Method: description
#######################################################################
#Routine to store a description of the script
#######################################################################
sub _description {
use strict 'refs';
my($self) = shift;
$self->{'description'} = shift;
}
#### Method: pattern
#######################################################################
#Routine to specify pattern(s) for a particular argument
#######################################################################
sub _pattern {
my($self) = shift;
my($parameter) = shift;
my($pKind) = (exists $self->{'special'}->{$parameter})? 'special' : 'parameter';
my($i) = 0;
if (exists $self->{$pKind}->{$parameter}->{'nameOrder'}) {
my($name) = shift;
croak "Subparameter ($name) not found for '$parameter'"
unless (exists $self->{$pKind}->{$parameter}->{'nameOrder'}->{$name});
$i = $self->{$pKind}->{$parameter}->{'nameOrder'}->{$name};
}
push(@{$self->{$pKind}->{$parameter}->{'pattern'}->[$i]}, @_); }
#### Method: help
#######################################################################
#Routine to specify the help string of a parameter
#######################################################################
sub _h { &_help(@_); }
sub _help {
use strict 'refs';
my($self) = shift;
#If only one argument, take as description string for entire script, not for a specific parameter
if (@_ == 1) {
$self->{'description'} = $_[0];
chomp($self->{'description'});
} elsif (@_ == 2) {
my($pKind) = (exists $self->{'special'}->{$_[0]})? 'special' : 'parameter';
$self->{$pKind}->{$_[0]}->{'help'} = $_[1];
chomp($self->{$pKind}->{$_[0]}->{'help'});
} else {
croak "Incorrect number of arguments to 'help' method.";
}
}
#### Method: help_option
#######################################################################
#Routine to specify the help option for special parameters
#######################################################################
sub _h_opt { &_help_option(@_); }
sub _help_option {
my($self) = shift;
if (@_ == 2) {
$self->{'special'}->{$_[0]}->{'help_option'} = $_[1];
Getopt/ExPar.pm view on Meta::CPAN
},
],
};
#Real
$self->{'types'}->{'real'} =
{ 'number_of_arguments' => 1,
'arguments' => [
{ 'range' => [],
'pattern' => [ '^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)?' . "\$", ],
'translation' => {},
'range_translation' => {},
'pattern_translation' => {},
},
],
};
#File
$self->{'types'}->{'file'} =
{ 'number_of_arguments' => 1,
'arguments' => [
{ 'range' => [],
'pattern' => [],
'translation' => {},
'range_translation' => {},
'pattern_translation' => {},
},
],
};
#String
$self->{'types'}->{'string'} =
{ 'number_of_arguments' => 1,
'arguments' => [
{ 'range' => [],
'pattern' => [],
'translation' => {},
'range_translation' => {},
'pattern_translation' => {},
},
],
};
#######################################################################
#ArgumentFile: a file containing more command line arguments to parse
#######################################################################
$self->{'types'}->{'argumentFile'} =
{ 'number_of_arguments' => 1,
'arguments' => [
{ 'range' => [],
'pattern' => [],
'translation' => {},
'range_translation' => {},
'pattern_translation' => {},
},
],
};
}
#### Method: _parse_prefs
#######################################################################
#Routine to parse prefs hash
#######################################################################
sub __parse_prefs {
my($self, $prefs) = @_;
#Overwrite elements in $self as specified by $prefs hash
foreach my $prefKey (keys %{$prefs}) {
croak "Unknown preference '$prefKey' specified" unless (exists $self->{'prefs'}->{$prefKey});
if (ref($self->{'prefs'}->{$prefKey}) eq 'HASH') {
foreach my $key ( @{$prefs->{$prefKey}} ) {
$self->{'prefs'}->{$prefKey}->{$key} = 1;
}
} else {
$self->{'prefs'}->{$prefKey} = $prefs->{$prefKey};
}
}
}
#########################################################################
#Auxiliary routine to return number of arguments for specified parameter
# according to type definition.
#########################################################################
sub __number_of_arguments {
my($self) = @_;
}
#######################################################################
#Auxiliary routine to print out help text
#######################################################################
sub __print_help {
my($self, $argv, $lvl) = @_;
$lvl = 0 unless (defined $lvl);
#Build up a help string:
print "\nDESCRIPTION:\n", $self->{'description'}, "\n" if (exists $self->{'description'});
#$0 <required options> [optional options]
my($help) = [ "\nUSAGE:\n$0", ];
foreach my $opt ( grep { (exists $self->{'parameter'}->{$_}->{'required'}) and ($self->{'parameter'}->{$_}->{'required'} == 1) }
sort keys %{$self->{'parameter'}} ) {
push(@{$help}, "-$opt");
push(@{$help}, join(' ', map { "<$_>" } @{$self->{'parameter'}->{$opt}->{'type'}}))
unless ($self->{'types'}->{$self->{'parameter'}->{$opt}->{'type'}->[0]}->{'number_of_arguments'} == 0);
}
foreach my $opt ( grep { (exists $self->{'special'}->{$_}->{'required'}) and ($self->{'special'}->{$_}->{'required'} == 1) }
sort keys %{$self->{'special'}} ) {
push(@{$help}, (exists $self->{'special'}->{$_}->{'help_option'})? $self->{'special'}->{$_}->{'help_option'} : $self->{'special'}->{$_}->{'pattern'});
}
foreach my $opt ( grep { (not exists $self->{'parameter'}->{$_}->{'required'}) or ($self->{'parameter'}->{$_}->{'required'} == 0) }
sort keys %{$self->{'parameter'}} ) {
push(@{$help}, "[-$opt");
push(@{$help}, join(' ', map { "<$_>" } @{$self->{'parameter'}->{$opt}->{'type'}}))
unless ($self->{'types'}->{$self->{'parameter'}->{$opt}->{'type'}->[0]}->{'number_of_arguments'} == 0);
$help->[$#{$help}] .= "]";
}
foreach my $opt ( grep { (not exists $self->{'special'}->{$_}->{'required'}) or ($self->{'special'}->{$_}->{'required'} == 0) }
sort keys %{$self->{'special'}} ) {
push(@{$help}, '[' . ((exists $self->{'special'}->{$opt}->{'help_option'})? $self->{'special'}->{$opt}->{'help_option'} : $self->{'special'}->{$opt}->{'special_pattern'}));
push(@{$help}, join(' ', map { "<$_>" } @{$self->{'special'}->{$opt}->{'type'}}))
unless ($self->{'types'}->{$self->{'special'}->{$opt}->{'type'}->[0]}->{'number_of_arguments'} == 0);
$help->[$#{$help}] .= ']';
}
print join(' ', @{$help}), "\n\n";
#Print extended help messages if full_help
if ($lvl > 1) {
$help = {};
foreach my $opt ( sort keys %{$self->{'parameter'}} ) {
my($key) = "-$opt";
$key .= join(' ', '', map { "<$_>" } @{$self->{'parameter'}->{$opt}->{'type'}})
unless ($self->{'types'}->{$self->{'parameter'}->{$opt}->{'type'}->[0]}->{'number_of_arguments'} == 0);
$help->{$key} = (exists $self->{'parameter'}->{$opt}->{'help'})? $self->{'parameter'}->{$opt}->{'help'} : '__no help text__';
}
foreach my $opt ( sort keys %{$self->{'special'}} ) {
my($key) = (exists $self->{'special'}->{$opt}->{'help_option'})? $self->{'special'}->{$opt}->{'help_option'} : $self->{'special'}->{$opt}->{'special_pattern'};
$key .= join(' ', '', map { "<$_>" } @{$self->{'special'}->{$opt}->{'type'}})
unless ($self->{'types'}->{$self->{'special'}->{$opt}->{'type'}->[0]}->{'number_of_arguments'} == 0);
( run in 1.218 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )