-# 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 ################
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.
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 = "(--|-)";
$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.
$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 ################
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;
#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
$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)",
"order=$order,",
"\n ",
"ignorecase=$ignorecase,",
+ "autohelp=$auto_help,",
+ "autoversion=$auto_version,",
"passthrough=$passthrough,",
"genprefix=\"$genprefix\".",
"\n")
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);
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;
if ( $spec eq '!' ) {
$opctl->{"no$_"} = $entry;
+ $opctl->{"no-$_"} = $entry;
$opctl->{$_} = [@$entry];
$opctl->{$_}->[CTL_TYPE] = '';
}
$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;
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;
$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 '';
}
# 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]+)?$/ ) {
}
}
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);
}
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;
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;
}
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
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
=head1 NAME
- sample - Using GetOpt::Long and Pod::Usage
+ sample - Using Getopt::Long and Pod::Usage
=head1 SYNOPSIS
=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.
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
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
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
=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
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
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
projects / p5sagit/p5-mst-13.2.git / commitdiff