lib/Getopt/Std.pm

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