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