package Getopt::Std; require 5.000; require Exporter; =head1 NAME Getopt::Std - Process single-character switches with switch clustering =head1 SYNOPSIS use Getopt::Std; getopts('oif:'); # -o & -i are boolean flags, -f takes an argument # Sets $opt_* as a side effect. getopts('oif:', \%opts); # options as above. Values in %opts getopt('oDI'); # -o, -D & -I take arg. # Sets $opt_* as a side effect. getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts =head1 DESCRIPTION The C<getopts()> function processes single-character switches with switch clustering. Pass one argument which is a string containing all switches to be recognized. For each switch found, if an argument is expected and provided, C<getopts()> sets C<$opt_x> (where C<x> is the switch name) to the value of the argument. If an argument is expected but none is provided, C<$opt_x> is set to an undefined value. If a switch does not take an argument, C<$opt_x> is set to C<1>. Switches which take an argument don't care whether there is a space between the switch and the argument. If unspecified switches are found on the command-line, the user will be warned that an unknown option was given. The C<getopts()> function returns true unless an invalid option was found. The C<getopt()> function is similar, but its argument is a string containing all switches that take an argument. If no argument is provided for a switch, say, C<y>, the corresponding C<$opt_y> will be set to an undefined value. Unspecified switches are silently accepted. Use of C<getopt()> is not recommended. Note that, if your code is running under the recommended C<use strict vars> pragma, you will need to declare these package variables with C<our>: our($opt_x, $opt_y); For those of you who don't like additional global variables being created, C<getopt()> and C<getopts()> will also accept a hash reference as an optional second argument. Hash keys will be C<x> (where C<x> is the switch name) with key values the value of the argument or C<1> if no argument is specified. To allow programs to process arguments that look like switches, but aren't, both functions will stop processing switches when they see the argument C<-->. The C<--> will be removed from @ARGV. =head1 C<--help> and C<--version> If C<-> is not a recognized switch letter, getopts() supports arguments C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are the output file handle, the name of option-processing package, its version, and the switches string. If the subroutines are not defined, an attempt is made to generate intelligent messages; for best results, define $main::VERSION. If embedded documentation (in pod format, see L<perlpod>) is detected in the script, C<--help> will also show how to access the documentation. Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION isn't true (the default is false), then the messages are printed on STDERR, and the processing continues after the messages are printed. This being the opposite of the standard-conforming behaviour, it is strongly recommended to set $Getopt::Std::STANDARD_HELP_VERSION to true. One can change the output file handle of the messages by setting $Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help> (without the C<Usage:> line) and C<--version> by calling functions help_mess() and version_mess() with the switches string as an argument. =cut @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); $VERSION = '1.12'; # uncomment the next line to disable 1.03-backward compatibility paranoia # $STANDARD_HELP_VERSION = 1; # Process single-character switches with switch clustering. Pass one argument # which is a string containing all switches that take an argument. For each # switch found, sets $opt_x (where x is the switch name) to the value of the # argument, or 1 if no argument. Switches which take an argument don't care # whether there is a space between the switch and the argument. # Usage: # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. sub getopt (;$$) { my ($argumentative, $hash) = @_; $argumentative = '' if !defined $argumentative; my ($first,$rest); local $_; local @EXPORT; while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); if (/^--$/) { # early exit if -- shift @ARGV; last; } if (index($argumentative,$first) >= 0) { if ($rest ne '') { shift(@ARGV); } else { shift(@ARGV); $rest = shift(@ARGV); } if (ref $hash) { $$hash{$first} = $rest; } else { ${"opt_$first"} = $rest; push( @EXPORT, "\$opt_$first" ); } } else { if (ref $hash) { $$hash{$first} = 1; } else { ${"opt_$first"} = 1; push( @EXPORT, "\$opt_$first" ); } if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } unless (ref $hash) { local $Exporter::ExportLevel = 1; import Getopt::Std; } } sub output_h () { return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; return \*STDOUT if $STANDARD_HELP_VERSION; return \*STDERR; } sub try_exit () { exit 0 if $STANDARD_HELP_VERSION; my $p = __PACKAGE__; print {output_h()} <<EOM; [Now continuing due to backward compatibility and excessive paranoia. See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.] EOM } sub version_mess ($;$) { my $args = shift; my $h = output_h; if (@_ and defined &main::VERSION_MESSAGE) { main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args); } else { my $v = $main::VERSION; $v = '[unknown]' unless defined $v; my $myv = $VERSION; $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION; my $perlv = $]; $perlv = sprintf "%vd", $^V if $] >= 5.006; print $h <<EOH; $0 version $v calling Getopt::Std::getopts (version $myv), running under Perl version $perlv. EOH } } sub help_mess ($;$) { my $args = shift; my $h = output_h; if (@_ and defined &main::HELP_MESSAGE) { main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args); } else { my (@witharg) = ($args =~ /(\S)\s*:/g); my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g); my ($help, $arg) = ('', ''); if (@witharg) { $help .= "\n\tWith arguments: -" . join " -", @witharg; $arg = "\nSpace is not required between options and their arguments."; } if (@rest) { $help .= "\n\tBoolean (without arguments): -" . join " -", @rest; } my ($scr) = ($0 =~ m,([^/\\]+)$,); print $h <<EOH if @_; # Let the script override this Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] EOH print $h <<EOH; The following single-character options are accepted:$help Options may be merged together. -- stops processing of options.$arg EOH my $has_pod; if ( defined $0 and $0 ne '-e' and -f $0 and -r $0 and open my $script, '<', $0 ) { while (<$script>) { $has_pod = 1, last if /^=(pod|head1)/; } } print $h <<EOH if $has_pod; For more details run perldoc -F $0 EOH } } # Usage: # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a # # side effect. sub getopts ($;$) { my ($argumentative, $hash) = @_; my (@args,$first,$rest,$exit); my $errs = 0; local $_; local @EXPORT; @args = split( / */, $argumentative ); while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { ($first,$rest) = ($1,$2); if (/^--$/) { # early exit if -- shift @ARGV; last; } my $pos = index($argumentative,$first); if ($pos >= 0) { if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { shift(@ARGV); if ($rest eq '') { ++$errs unless @ARGV; $rest = shift(@ARGV); } if (ref $hash) { $$hash{$first} = $rest; } else { ${"opt_$first"} = $rest; push( @EXPORT, "\$opt_$first" ); } } else { if (ref $hash) { $$hash{$first} = 1; } else { ${"opt_$first"} = 1; push( @EXPORT, "\$opt_$first" ); } if ($rest eq '') { shift(@ARGV); } else { $ARGV[0] = "-$rest"; } } } else { if ($first eq '-' and $rest eq 'help') { version_mess($argumentative, 'main'); help_mess($argumentative, 'main'); try_exit(); shift(@ARGV); next; } elsif ($first eq '-' and $rest eq 'version') { version_mess($argumentative, 'main'); try_exit(); shift(@ARGV); next; } warn "Unknown option: $first\n"; ++$errs; if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } unless (ref $hash) { local $Exporter::ExportLevel = 1; import Getopt::Std; } $errs == 0; } 1;