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) = @_;