lib/Getopt/Std.pm

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