diff options
Diffstat (limited to 'lib/Getopt/Long.pm')
| -rw-r--r-- | lib/Getopt/Long.pm | 337 |
1 files changed, 294 insertions, 43 deletions
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 7e1663d557..8ee23227c6 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,13 +1,13 @@ -# GetOpt::Long.pm -- Universal options parsing +# Getopt::Long.pm -- Universal options parsing package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.58 2002-06-20 09:32:09+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.63 2003-04-04 18:44:03+02 jv Exp jv $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Thu Jun 20 07:48:05 2002 -# Update Count : 1083 +# Last Modified On: Thu May 15 14:48:48 2003 +# Update Count : 1321 # Status : Released ################ Copyright ################ @@ -35,20 +35,25 @@ use 5.004; use strict; use vars qw($VERSION); -$VERSION = 2.32; +$VERSION = 2.3205; # For testing versions only. use vars qw($VERSION_STRING); -$VERSION_STRING = "2.32"; +$VERSION_STRING = "2.32_05"; use Exporter; - -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +use vars qw(@ISA @EXPORT @EXPORT_OK); @ISA = qw(Exporter); -%EXPORT_TAGS = qw(); + +# Exported subroutines. +sub GetOptions(@); # always +sub Configure(@); # on demand +sub HelpMessage(@); # on demand +sub VersionMessage(@); # in demand + BEGIN { # Init immediately so their contents can be used in the 'use vars' below. - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - @EXPORT_OK = qw(); + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure); } # User visible variables. @@ -58,24 +63,27 @@ use vars qw($error $debug $major_version $minor_version); use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order $passthrough); # Official invisible variables. -use vars qw($genprefix $caller $gnu_compat); +use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version); # Public subroutines. -sub Configure (@); -sub config (@); # deprecated name -sub GetOptions; +sub config(@); # deprecated name # Private subroutines. -sub ConfigDefaults (); -sub ParseOptionSpec ($$); -sub OptCtl ($); -sub FindOption ($$$$); +sub ConfigDefaults(); +sub ParseOptionSpec($$); +sub OptCtl($); +sub FindOption($$$$); ################ Local Variables ################ +# $requested_version holds the version that was mentioned in the 'use' +# or 'require', if any. It can be used to enable or disable specific +# features. +my $requested_version = 0; + ################ Resident subroutines ################ -sub ConfigDefaults () { +sub ConfigDefaults() { # Handle POSIX compliancy. if ( defined $ENV{"POSIXLY_CORRECT"} ) { $genprefix = "(--|-)"; @@ -97,6 +105,10 @@ sub ConfigDefaults () { $ignorecase = 1; # ignore case when matching options $passthrough = 0; # leave unrecognized options alone $gnu_compat = 0; # require --opt=val if value is optional + + # Version-dependent defaults. Leave undefined. + # $auto_help = $requested_version >= 2.3203; # supply --help handler + # $auto_version = $requested_version >= 2.3203; # supply --version handler } # Override import. @@ -110,13 +122,14 @@ sub import { $dest = \@config; # config next next; } - push (@$dest, $_); # push + push(@$dest, $_); # push } # Hide one level and call super. local $Exporter::ExportLevel = 1; + push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions $pkg->SUPER::import(@syms); # And configure. - Configure (@config) if @config; + Configure(@config) if @config; } ################ Initialization ################ @@ -205,6 +218,8 @@ sub getoptions { package Getopt::Long; +################ Back to Normal ################ + # Indices in option control info. # Note that ParseOptions uses the fields directly. Search for 'hard-wired'. use constant CTL_TYPE => 0; @@ -233,7 +248,7 @@ use constant CTL_DEFAULT => 4; #use constant CTL_RANGE => ; #use constant CTL_REPEAT => ; -sub GetOptions { +sub GetOptions(@) { my @optionlist = @_; # local copy of the option descriptions my $argend = '--'; # option list terminator @@ -248,8 +263,8 @@ sub GetOptions { $error = ''; - print STDERR ("GetOpt::Long $Getopt::Long::VERSION (", - '$Revision: 2.58 $', ") ", + print STDERR ("Getopt::Long $Getopt::Long::VERSION (", + '$Revision: 2.63 $', ") ", "called from package \"$pkg\".", "\n ", "ARGV: (@ARGV)", @@ -261,6 +276,8 @@ sub GetOptions { "order=$order,", "\n ", "ignorecase=$ignorecase,", + "autohelp=$auto_help,", + "autoversion=$auto_version,", "passthrough=$passthrough,", "genprefix=\"$genprefix\".", "\n") @@ -392,6 +409,20 @@ sub GetOptions { die ($error) if $error; $error = 0; + # Supply --version and --help support, if needed and allowed. + if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{version}) ) { + $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; + $linkage{version} = \&VersionMessage; + } + } + if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { + $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; + $linkage{help} = \&HelpMessage; + } + } + # Show the options tables if debugging. if ( $debug ) { my ($arrow, $k, $v); @@ -411,7 +442,10 @@ sub GetOptions { print STDERR ("=> arg \"", $opt, "\"\n") if $debug; # Double dash is option list terminator. - last if $opt eq $argend; + if ( $opt eq $argend ) { + push (@ret, $argend) if $passthrough; + last; + } # Look it up. my $tryopt = $opt; @@ -698,6 +732,7 @@ sub ParseOptionSpec ($$) { if ( $spec eq '!' ) { $opctl->{"no$_"} = $entry; + $opctl->{"no-$_"} = $entry; $opctl->{$_} = [@$entry]; $opctl->{$_}->[CTL_TYPE] = ''; } @@ -853,7 +888,7 @@ sub FindOption ($$$$) { $arg = 1; } else { - $opt =~ s/^no//i; # strip NO prefix + $opt =~ s/^no-?//i; # strip NO prefix $arg = 0; # supply explicit value } unshift (@ARGV, $starter.$rest) if defined $rest; @@ -899,11 +934,21 @@ sub FindOption ($$$$) { my $key; if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) - : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 1); + : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + ($mand ? undef : ($type eq 's' ? "" : 1))); + if (! defined $arg) { + warn ("Option $opt, key \"$key\", requires a value\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } } #### Check if the argument is valid for this option #### + my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; + if ( $type eq 's' ) { # string # A mandatory string takes anything. return (1, $opt, $ctl, $arg, $key) if $mand; @@ -931,9 +976,10 @@ sub FindOption ($$$$) { $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" : "[-+]?[0-9]+"; - if ( $bundling && defined $rest && $rest =~ /^($o_valid)(.*)$/si ) { - $arg = $1; - $rest = $2; + if ( $bundling && defined $rest + && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } @@ -976,9 +1022,9 @@ sub FindOption ($$$$) { # and at least one digit following the point and 'e'. # [-]NN[.NN][eNN] if ( $bundling && defined $rest && - $rest =~ /^([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) { - $arg = $1; - $rest = $+; + $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { @@ -1004,7 +1050,7 @@ sub FindOption ($$$$) { } } else { - die("GetOpt::Long internal error (Can't happen)\n"); + die("Getopt::Long internal error (Can't happen)\n"); } return (1, $opt, $ctl, $arg, $key); } @@ -1016,12 +1062,13 @@ sub Configure (@) { my $prevconfig = [ $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix ]; + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ]; if ( ref($options[0]) eq 'ARRAY' ) { ( $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)}; + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help ) = + @{shift(@options)}; } my $opt; @@ -1057,6 +1104,12 @@ sub Configure (@) { elsif ( $try eq 'gnu_compat' ) { $gnu_compat = $action; } + elsif ( $try =~ /^(auto_?)?version$/ ) { + $auto_version = $action; + } + elsif ( $try =~ /^(auto_?)?help$/ ) { + $auto_help = $action; + } elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { $ignorecase = $action; } @@ -1108,6 +1161,100 @@ sub config (@) { Configure (@_); } +# Issue a standard message for --version. +# +# The arguments are mostly the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub VersionMessage(@) { + # Massage args. + my $pa = setup_pa_args("version", @_); + + my $v = $main::VERSION; + my $fh = $pa->{-output} || + ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; + + print $fh (defined($pa->{-message}) ? $pa->{-message} : (), + $0, defined $v ? " version $v" : (), + "\n", + "(", __PACKAGE__, "::", "GetOptions", + " version ", + defined($VERSION_STRING) ? $VERSION_STRING : $VERSION, ";", + " Perl version ", + $] >= 5.006 ? sprintf("%vd", $^V) : $], + ")\n"); + exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; +} + +# Issue a standard message for --help. +# +# The arguments are the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub HelpMessage(@) { + eval { + require Pod::Usage; + import Pod::Usage; + 1; + } || die("Cannot provide help: cannot load Pod::Usage\n"); + + # Note that pod2usage will issue a warning if -exitval => NOEXIT. + pod2usage(setup_pa_args("help", @_)); + +} + +# Helper routine to set up a normalized hash ref to be used as +# argument to pod2usage. +sub setup_pa_args($@) { + my $tag = shift; # who's calling + + # If called by direct binding to an option, it will get the option + # name and value as arguments. Remove these, if so. + @_ = () if @_ == 2 && $_[0] eq $tag; + + my $pa; + if ( @_ > 1 ) { + $pa = { @_ }; + } + else { + $pa = shift || {}; + } + + # At this point, $pa can be a number (exit value), string + # (message) or hash with options. + + if ( UNIVERSAL::isa($pa, 'HASH') ) { + # Get rid of -msg vs. -message ambiguity. + $pa->{-message} = $pa->{-msg}; + delete($pa->{-msg}); + } + elsif ( $pa =~ /^-?\d+$/ ) { + $pa = { -exitval => $pa }; + } + else { + $pa = { -message => $pa }; + } + + # These are _our_ defaults. + $pa->{-verbose} = 0 unless exists($pa->{-verbose}); + $pa->{-exitval} = 0 unless exists($pa->{-exitval}); + $pa; +} + +# Sneak way to know what version the user requested. +sub VERSION { + $requested_version = $_[1]; + shift->SUPER::VERSION(@_); +} + +1; + ################ Documentation ################ =head1 NAME @@ -1425,7 +1572,7 @@ The argument specification can be The option does not take an argument and may be negated, i.e. prefixed by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be -assigned) and C<--nofoo> (a value of 0 will be assigned). If the +assigned) and C<--nofoo> and C<--no-foo> (a value of 0 will be assigned). If the option has aliases, this applies to the aliases as well. Using negation on a single letter option when bundling is in effect is @@ -1538,7 +1685,7 @@ messages. For example: =head1 NAME - sample - Using GetOpt::Long and Pod::Usage + sample - Using Getopt::Long and Pod::Usage =head1 SYNOPSIS @@ -1689,7 +1836,7 @@ it will set variable C<$stdio>. =head2 Argument callback -A special option 'name' C<<>> can be used to designate a subroutine +A special option 'name' C<< <> >> can be used to designate a subroutine to handle non-option arguments. When GetOptions() encounters an argument that does not look like an option, it will immediately call this subroutine and passes it one parameter: the argument name. @@ -1712,7 +1859,6 @@ C<process("arg3")> while C<$width> is C<60>. This feature requires configuration option B<permute>, see section L<Configuring Getopt::Long>. - =head1 Configuring Getopt::Long Getopt::Long can be configured by calling subroutine @@ -1861,6 +2007,25 @@ options also. Note: disabling C<ignore_case_always> also disables C<ignore_case>. +=item auto_version (default:disabled) + +Automatically provide support for the B<--version> option if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a standard version message that includes the +program name, its version (if $main::VERSION is defined), and the +versions of Getopt::Long and Perl. The message will be written to +standard output and processing will terminate. + +=item auto_help (default:disabled) + +Automatically provide support for the B<--help> and B<-?> options if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a help message using module Pod::Usage. The +message, derived from the SYNOPSIS POD section, will be written to +standard output and processing will terminate. + =item pass_through (default: disabled) Options that are unknown, ambiguous or supplied with an invalid option @@ -1873,6 +2038,9 @@ If C<require_order> is enabled, options processing will terminate at the first unrecognized option, or non-option, whichever comes first. However, if C<permute> is enabled instead, results can become confusing. +Note that the options terminator (default C<-->), if present, will +also be passed through in C<@ARGV>. + =item prefix The string that starts options. If a constant string is not @@ -1890,6 +2058,83 @@ Enable debugging output. =back +=head1 Exportable Methods + +=over + +=item VersionMessage + +This subroutine provides a standard version message. Its argument can be: + +=over 4 + +=item * + +A string containing the text of a message to print I<before> printing +the standard message. + +=item * + +A numeric value corresponding to the desired exit status. + +=item * + +A reference to a hash. + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over 4 + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B<exit()> function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=back + +You cannot tie this routine directly to an option, e.g.: + + GetOptions("version" => \&VersionMessage); + +Use this instead: + + GetOptions("version" => sub { VersionMessage() }); + +=item HelpMessage + +This subroutine produces a standard help message, derived from the +program's POD section SYNOPSIS using Pod::Usage. It takes the same +arguments as VersionMessage(). In particular, you cannot tie it +directly to an option, e.g.: + + GetOptions("help" => \&HelpMessage); + +Use this instead: + + GetOptions("help" => sub { HelpMessage() }); + +=back + =head1 Return values and Errors Configuration errors and errors in the option definitions are @@ -1902,8 +2147,6 @@ It returns false when the function detected one or more errors during option parsing. These errors are signalled using warn() and can be trapped with C<$SIG{__WARN__}>. -Errors that can't happen are signalled using Carp::croak(). - =head1 Legacy The earliest development of C<newgetopt.pl> started in 1990, with Perl @@ -2014,6 +2257,14 @@ program: to verify how your CLI passes the arguments to the program. +=head2 Undefined subroutine &main::GetOptions called + +Are you running Windows, and did you write + + use GetOpt::Long; + +(note the capital 'O')? + =head2 How do I put a "-?" option into a Getopt::Long? You can only obtain this using an alias, and Getopt::Long of at least |