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