Getopt-ExPar
view release on metacpan or search on metacpan
Getopt/ExPar.pm view on Meta::CPAN
#
# 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;
Getopt/ExPar.pm view on Meta::CPAN
#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 = [];
Getopt/ExPar.pm view on Meta::CPAN
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);
Getopt/ExPar.pm view on Meta::CPAN
}
}
}
}
#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++;
Getopt/ExPar.pm view on Meta::CPAN
}
#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) {
Getopt/ExPar.pm view on Meta::CPAN
}
}
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);
Getopt/ExPar.pm view on Meta::CPAN
} 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 {
Getopt/ExPar.pm view on Meta::CPAN
# 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'}} ) {
Getopt/ExPar.pm view on Meta::CPAN
#### 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'}};
}
Getopt/ExPar.pm view on Meta::CPAN
#######################################################################
# 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'}};
}
Getopt/ExPar.pm view on Meta::CPAN
} 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";
Getopt/ExPar.pm view on Meta::CPAN
#### 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;
}
}
Getopt/ExPar.pm view on Meta::CPAN
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.";
Getopt/ExPar.pm view on Meta::CPAN
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;
Getopt/ExPar.pm view on Meta::CPAN
'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) = @_;
( run in 1.301 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )