[Summary view] [Print] [Text view]

   1  package Getopt::Std;
   2  require 5.000;
   3  require Exporter;
   4  
   5  =head1 NAME
   6  
   7  getopt, getopts - Process single-character switches with switch clustering
   8  
   9  =head1 SYNOPSIS
  10  
  11      use Getopt::Std;
  12  
  13      getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
  14      getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
  15      getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
  16                # Sets $opt_* as a side effect.
  17      getopts('oif:', \%opts);  # options as above. Values in %opts
  18  
  19  =head1 DESCRIPTION
  20  
  21  The getopt() function processes single-character switches with switch
  22  clustering.  Pass one argument which is a string containing all switches
  23  that take an argument.  For each switch found, sets $opt_x (where x is the
  24  switch name) to the value of the argument if an argument is expected,
  25  or 1 otherwise.  Switches which take an argument don't care whether
  26  there is a space between the switch and the argument.
  27  
  28  The getopts() function is similar, but you should pass to it the list of all
  29  switches to be recognized.  If unspecified switches are found on the
  30  command-line, the user will be warned that an unknown option was given.
  31  The getopts() function returns true unless an invalid option was found.
  32  
  33  Note that, if your code is running under the recommended C<use strict
  34  'vars'> pragma, you will need to declare these package variables
  35  with "our":
  36  
  37      our($opt_x, $opt_y);
  38  
  39  For those of you who don't like additional global variables being created, getopt()
  40  and getopts() will also accept a hash reference as an optional second argument. 
  41  Hash keys will be x (where x is the switch name) with key values the value of
  42  the argument or 1 if no argument is specified.
  43  
  44  To allow programs to process arguments that look like switches, but aren't,
  45  both functions will stop processing switches when they see the argument
  46  C<-->.  The C<--> will be removed from @ARGV.
  47  
  48  =head1 C<--help> and C<--version>
  49  
  50  If C<-> is not a recognized switch letter, getopts() supports arguments
  51  C<--help> and C<--version>.  If C<main::HELP_MESSAGE()> and/or
  52  C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
  53  the output file handle, the name of option-processing package, its version,
  54  and the switches string.  If the subroutines are not defined, an attempt is
  55  made to generate intelligent messages; for best results, define $main::VERSION.
  56  
  57  If embedded documentation (in pod format, see L<perlpod>) is detected
  58  in the script, C<--help> will also show how to access the documentation.
  59  
  60  Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
  61  isn't true (the default is false), then the messages are printed on STDERR,
  62  and the processing continues after the messages are printed.  This being
  63  the opposite of the standard-conforming behaviour, it is strongly recommended
  64  to set $Getopt::Std::STANDARD_HELP_VERSION to true.
  65  
  66  One can change the output file handle of the messages by setting
  67  $Getopt::Std::OUTPUT_HELP_VERSION.  One can print the messages of C<--help>
  68  (without the C<Usage:> line) and C<--version> by calling functions help_mess()
  69  and version_mess() with the switches string as an argument.
  70  
  71  =cut
  72  
  73  @ISA = qw(Exporter);
  74  @EXPORT = qw(getopt getopts);
  75  $VERSION = '1.05';
  76  # uncomment the next line to disable 1.03-backward compatibility paranoia
  77  # $STANDARD_HELP_VERSION = 1;
  78  
  79  # Process single-character switches with switch clustering.  Pass one argument
  80  # which is a string containing all switches that take an argument.  For each
  81  # switch found, sets $opt_x (where x is the switch name) to the value of the
  82  # argument, or 1 if no argument.  Switches which take an argument don't care
  83  # whether there is a space between the switch and the argument.
  84  
  85  # Usage:
  86  #    getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  87  
  88  sub getopt (;$$) {
  89      my ($argumentative, $hash) = @_;
  90      $argumentative = '' if !defined $argumentative;
  91      my ($first,$rest);
  92      local $_;
  93      local @EXPORT;
  94  
  95      while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  96      ($first,$rest) = ($1,$2);
  97      if (/^--$/) {    # early exit if --
  98          shift @ARGV;
  99          last;
 100      }
 101      if (index($argumentative,$first) >= 0) {
 102          if ($rest ne '') {
 103          shift(@ARGV);
 104          }
 105          else {
 106          shift(@ARGV);
 107          $rest = shift(@ARGV);
 108          }
 109          if (ref $hash) {
 110              $$hash{$first} = $rest;
 111          }
 112          else {
 113              ${"opt_$first"} = $rest;
 114              push( @EXPORT, "\$opt_$first" );
 115          }
 116      }
 117      else {
 118          if (ref $hash) {
 119              $$hash{$first} = 1;
 120          }
 121          else {
 122              ${"opt_$first"} = 1;
 123              push( @EXPORT, "\$opt_$first" );
 124          }
 125          if ($rest ne '') {
 126          $ARGV[0] = "-$rest";
 127          }
 128          else {
 129          shift(@ARGV);
 130          }
 131      }
 132      }
 133      unless (ref $hash) { 
 134      local $Exporter::ExportLevel = 1;
 135      import Getopt::Std;
 136      }
 137  }
 138  
 139  sub output_h () {
 140    return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
 141    return \*STDOUT if $STANDARD_HELP_VERSION;
 142    return \*STDERR;
 143  }
 144  
 145  sub try_exit () {
 146      exit 0 if $STANDARD_HELP_VERSION;
 147      my $p = __PACKAGE__;
 148      print {output_h()} <<EOM;
 149    [Now continuing due to backward compatibility and excessive paranoia.
 150     See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
 151  EOM
 152  }
 153  
 154  sub version_mess ($;$) {
 155      my $args = shift;
 156      my $h = output_h;
 157      if (@_ and defined &main::VERSION_MESSAGE) {
 158      main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
 159      } else {
 160      my $v = $main::VERSION;
 161      $v = '[unknown]' unless defined $v;
 162      my $myv = $VERSION;
 163      $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
 164      my $perlv = $];
 165      $perlv = sprintf "%vd", $^V if $] >= 5.006;
 166      print $h <<EOH;
 167  $0 version $v calling Getopt::Std::getopts (version $myv),
 168  running under Perl version $perlv.
 169  EOH
 170      }
 171  }
 172  
 173  sub help_mess ($;$) {
 174      my $args = shift;
 175      my $h = output_h;
 176      if (@_ and defined &main::HELP_MESSAGE) {
 177      main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
 178      } else {
 179      my (@witharg) = ($args =~ /(\S)\s*:/g);
 180      my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
 181      my ($help, $arg) = ('', '');
 182      if (@witharg) {
 183          $help .= "\n\tWith arguments: -" . join " -", @witharg;
 184          $arg = "\nSpace is not required between options and their arguments.";
 185      }
 186      if (@rest) {
 187          $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
 188      }
 189      my ($scr) = ($0 =~ m,([^/\\]+)$,);
 190      print $h <<EOH if @_;            # Let the script override this
 191  
 192  Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
 193  EOH
 194      print $h <<EOH;
 195  
 196  The following single-character options are accepted:$help
 197  
 198  Options may be merged together.  -- stops processing of options.$arg
 199  EOH
 200      my $has_pod;
 201      if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
 202           and open my $script, '<', $0 ) {
 203          while (<$script>) {
 204          $has_pod = 1, last if /^=(pod|head1)/;
 205          }
 206      }
 207      print $h <<EOH if $has_pod;
 208  
 209  For more details run
 210      perldoc -F $0
 211  EOH
 212      }
 213  }
 214  
 215  # Usage:
 216  #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
 217  #            #  side effect.
 218  
 219  sub getopts ($;$) {
 220      my ($argumentative, $hash) = @_;
 221      my (@args,$first,$rest,$exit);
 222      my $errs = 0;
 223      local $_;
 224      local @EXPORT;
 225  
 226      @args = split( / */, $argumentative );
 227      while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
 228      ($first,$rest) = ($1,$2);
 229      if (/^--$/) {    # early exit if --
 230          shift @ARGV;
 231          last;
 232      }
 233      my $pos = index($argumentative,$first);
 234      if ($pos >= 0) {
 235          if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
 236          shift(@ARGV);
 237          if ($rest eq '') {
 238              ++$errs unless @ARGV;
 239              $rest = shift(@ARGV);
 240          }
 241          if (ref $hash) {
 242              $$hash{$first} = $rest;
 243          }
 244          else {
 245              ${"opt_$first"} = $rest;
 246              push( @EXPORT, "\$opt_$first" );
 247          }
 248          }
 249          else {
 250          if (ref $hash) {
 251              $$hash{$first} = 1;
 252          }
 253          else {
 254              ${"opt_$first"} = 1;
 255              push( @EXPORT, "\$opt_$first" );
 256          }
 257          if ($rest eq '') {
 258              shift(@ARGV);
 259          }
 260          else {
 261              $ARGV[0] = "-$rest";
 262          }
 263          }
 264      }
 265      else {
 266          if ($first eq '-' and $rest eq 'help') {
 267          version_mess($argumentative, 'main');
 268          help_mess($argumentative, 'main');
 269          try_exit();
 270          shift(@ARGV);
 271          next;
 272          } elsif ($first eq '-' and $rest eq 'version') {
 273          version_mess($argumentative, 'main');
 274          try_exit();
 275          shift(@ARGV);
 276          next;
 277          }
 278          warn "Unknown option: $first\n";
 279          ++$errs;
 280          if ($rest ne '') {
 281          $ARGV[0] = "-$rest";
 282          }
 283          else {
 284          shift(@ARGV);
 285          }
 286      }
 287      }
 288      unless (ref $hash) { 
 289      local $Exporter::ExportLevel = 1;
 290      import Getopt::Std;
 291      }
 292      $errs == 0;
 293  }
 294  
 295  1;