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     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.06';
  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;