X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FGetopt%2FLong.pm;h=2bb0548a2ca1184970742a216a132c7425a6fba8;hb=22d4bb9ccb8701e68f9243547d7e3a3c55f70908;hp=f474c7c4a9780fae7498a1e9b119b97713c1a377;hpb=4b19af017623bfa3bb72bb164598a517f586e0d3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index f474c7c..2bb0548 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,12 +2,12 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.24 2000-03-14 21:28:52+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Tue Mar 14 21:28:40 2000 -# Update Count : 721 +# Last Modified On: Mon Jul 31 21:21:13 2000 +# Update Count : 739 # Status : Released ################ Copyright ################ @@ -36,7 +36,7 @@ BEGIN { require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = "2.23"; + $VERSION = 2.24; @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -52,7 +52,7 @@ 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); +use vars qw($genprefix $caller $gnu_compat); # Public subroutines. sub Configure (@); @@ -89,6 +89,27 @@ sub ConfigDefaults () { $error = 0; # error tally $ignorecase = 1; # ignore case when matching options $passthrough = 0; # leave unrecognized options alone + $gnu_compat = 0; # require --opt=val if value is optional +} + +# Override import. +sub import { + my $pkg = shift; # package + my @syms = (); # symbols to import + my @config = (); # configuration + my $dest = \@syms; # symbols first + for ( @_ ) { + if ( $_ eq ':config' ) { + $dest = \@config; # config next + next; + } + push (@$dest, $_); # push + } + # Hide one level and call super. + local $Exporter::ExportLevel = 1; + $pkg->SUPER::import(@syms); + # And configure. + Configure (@config) if @config; } ################ Initialization ################ @@ -100,6 +121,87 @@ sub ConfigDefaults () { ConfigDefaults(); +################ OO Interface ################ + +package Getopt::Long::Parser; + +# NOTE: The object oriented routines use $error for thread locking. +my $_lock = sub { + lock ($Getopt::Long::error) if $] >= 5.005 +}; + +# Store a copy of the default configuration. Since ConfigDefaults has +# just been called, what we get from Configure is the default. +my $default_config = do { + &$_lock; + Getopt::Long::Configure () +}; + +sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; + + # Register the callers package. + my $self = { caller => (caller)[0] }; + + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + &$_lock; + my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); + $self->{settings} = Getopt::Long::Configure ($save); + delete ($atts{config}); + } + # Else use default config. + else { + $self->{settings} = $default_config; + } + + if ( %atts ) { # Oops + Getopt::Long::Croak(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))); + } + + $self; +} + +sub configure { + my ($self) = shift; + + &$_lock; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Configure ($save); +} + +sub getoptions { + my ($self) = shift; + + &$_lock; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller}; + eval { $ret = Getopt::Long::GetOptions (@_); }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; +} + +package Getopt::Long; + ################ Package return ################ 1; @@ -108,12 +210,12 @@ __END__ ################ AutoLoading subroutines ################ -# RCS Status : $Id: GetoptLongAl.pl,v 2.27 2000-03-17 09:07:26+01 jv Exp $ +# RCS Status : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp $ # Author : Johan Vromans # Created On : Fri Mar 27 11:50:30 1998 # Last Modified By: Johan Vromans -# Last Modified On: Fri Mar 17 09:00:09 2000 -# Update Count : 55 +# Last Modified On: Fri Jul 28 19:12:29 2000 +# Update Count : 97 # Status : Released sub GetOptions { @@ -137,13 +239,14 @@ sub GetOptions { print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", "called from package \"$pkg\".", "\n ", - 'GetOptionsAl $Revision: 2.27 $ ', + 'GetOptionsAl $Revision: 2.29 $ ', "\n ", "ARGV: (@ARGV)", "\n ", "autoabbrev=$autoabbrev,". "bundling=$bundling,", "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", "order=$order,", "\n ", "ignorecase=$ignorecase,", @@ -200,7 +303,7 @@ sub GetOptions { next; } - # Match option spec. Allow '?' as an alias. + # Match option spec. Allow '?' as an alias only. if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) { $error .= "Error in option spec: \"$opt\"\n"; next; @@ -208,14 +311,22 @@ sub GetOptions { my ($o, $c, $a) = ($1, $5); $c = '' unless defined $c; + # $linko keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $linko; + if ( ! defined $o ) { # empty -> '-' option - $opctl{$o = ''} = $c; + $opctl{$linko = $o = ''} = $c; } else { # Handle alias names my @o = split (/\|/, $o); - my $linko = $o = $o[0]; + $linko = $o = $o[0]; # Force an alias if the option name is not locase. $a = $o unless $o eq lc($o); $o = lc ($o) @@ -254,18 +365,18 @@ sub GetOptions { $a = $_; } } - $o = $linko; } # If no linkage is supplied in the @optionlist, copy it from # the userlinkage if available. if ( defined $userlinkage ) { unless ( @optionlist > 0 && ref($optionlist[0]) ) { - if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) { - print STDERR ("=> found userlinkage for \"$o\": ", - "$userlinkage->{$o}\n") + if ( exists $userlinkage->{$linko} && + ref($userlinkage->{$linko}) ) { + print STDERR ("=> found userlinkage for \"$linko\": ", + "$userlinkage->{$linko}\n") if $debug; - unshift (@optionlist, $userlinkage->{$o}); + unshift (@optionlist, $userlinkage->{$linko}); } else { # Do nothing. Being undefined will be handled later. @@ -276,13 +387,13 @@ sub GetOptions { # Copy the linkage. If omitted, link to global variable. if ( @optionlist > 0 && ref($optionlist[0]) ) { - print STDERR ("=> link \"$o\" to $optionlist[0]\n") + print STDERR ("=> link \"$linko\" to $optionlist[0]\n") if $debug; if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); } elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); $opctl{$o} .= '@' if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; $bopctl{$o} .= '@' @@ -290,7 +401,7 @@ sub GetOptions { $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; } elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { - $linkage{$o} = shift (@optionlist); + $linkage{$linko} = shift (@optionlist); $opctl{$o} .= '%' if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; $bopctl{$o} .= '%' @@ -304,22 +415,22 @@ sub GetOptions { else { # Link to global $opt_XXX variable. # Make sure a valid perl identifier results. - my $ov = $o; + my $ov = $linko; $ov =~ s/\W/_/g; if ( $c =~ /@/ ) { - print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;"); } elsif ( $c =~ /%/ ) { - print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;"); } else { - print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") + print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); + eval ("\$linkage{\$linko} = \\\$".$pkg."::opt_$ov;"); } } } @@ -382,7 +493,11 @@ sub GetOptions { next unless defined $opt; if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; + if ( defined $aliases{$opt} ) { + print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n") + if $debug; + $opt = $aliases{$opt}; + } if ( defined $linkage{$opt} ) { print STDERR ("=> ref(\$L{$opt}) -> ", @@ -646,7 +761,7 @@ sub FindOption ($$$$$$$) { } # Apparently valid. $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + print STDERR ("=> found \"$type\" for \"", $opt, "\"\n") if $debug; #### Determine argument status #### @@ -675,7 +790,16 @@ sub FindOption ($$$$$$$) { ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/; # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') + if ( $gnu_compat ) { + return (1, $opt, $optarg, $dsttype, $incr, $key) + if defined $optarg; + return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key) + if $mand eq ':'; + } + + # Check if there is an option argument available. + if ( defined $optarg + ? ($optarg eq '') : !(defined $rest || @ARGV > 0) ) { # Complain if this option needs an argument. if ( $mand eq "=" ) { @@ -684,10 +808,7 @@ sub FindOption ($$$$$$$) { $error++; undef $opt; } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; - } - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key); } # Get (possibly optional) argument. @@ -795,12 +916,12 @@ sub Configure (@) { my $prevconfig = [ $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $passthrough, $genprefix ]; + $gnu_compat, $passthrough, $genprefix ]; if ( ref($options[0]) eq 'ARRAY' ) { ( $error, $debug, $major_version, $minor_version, $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $passthrough, $genprefix ) = @{shift(@options)}; + $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)}; } my $opt; @@ -811,8 +932,13 @@ sub Configure (@) { $action = 0; $try = $+; } - if ( $try eq 'default' or $try eq 'defaults' ) { - ConfigDefaults () if $action; + if ( ($try eq 'default' or $try eq 'defaults') && $action ) { + ConfigDefaults (); + } + elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { + local $ENV{POSIXLY_CORRECT}; + $ENV{POSIXLY_CORRECT} = 1 if $action; + ConfigDefaults (); } elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { $autoabbrev = $action; @@ -820,6 +946,17 @@ sub Configure (@) { elsif ( $try eq 'getopt_compat' ) { $getopt_compat = $action; } + elsif ( $try eq 'gnu_getopt' ) { + if ( $action ) { + $gnu_compat = 1; + $bundling = 1; + $getopt_compat = 0; + $permute = 1; + } + } + elsif ( $try eq 'gnu_compat' ) { + $gnu_compat = $action; + } elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { $ignorecase = $action; } @@ -841,14 +978,14 @@ sub Configure (@) { elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { $passthrough = $action; } - elsif ( $try =~ /^prefix=(.+)$/ ) { + elsif ( $try =~ /^prefix=(.+)$/ && $action ) { $genprefix = $1; # Turn into regexp. Needs to be parenthesized! $genprefix = "(" . quotemeta($genprefix) . ")"; eval { '' =~ /$genprefix/; }; Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@; } - elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { $genprefix = $1; # Parenthesize if needed. $genprefix = "(" . $genprefix . ")" @@ -930,7 +1067,7 @@ could use the more descriptive C<--long>. To distinguish between a bundle of single-character options and a long one, two dashes are used to precede the option name. Early implementations of long options used a plus C<+> instead. Also, option values could be specified either -like +like --size=24 @@ -943,7 +1080,7 @@ The C<+> form is now obsolete and strongly deprecated. =head1 Getting Started with Getopt::Long Getopt::Long is the Perl5 successor of C. This was -the firs Perl module that provided support for handling the new style +the first Perl module that provided support for handling the new style of command line options, hence the name Getopt::Long. This module also supports single-character options and bundling. In this case, the options are restricted to alphabetic characters only, and the @@ -1166,11 +1303,11 @@ requires a least C<--hea> and C<--hei> for the head and height options. =head2 Summary of Option Specifications Each option specifier consists of two parts: the name specification -and the argument specification. +and the argument specification. The name specification contains the name of the option, optionally followed by a list of alternative names separated by vertical bar -characters. +characters. length option name is "length" length|size|l name is "length", aliases are "size" and "l" @@ -1243,6 +1380,24 @@ considered an option on itself. =head1 Advanced Possibilities +=head2 Object oriented interface + +Getopt::Long can be used in an object oriented way as well: + + use Getopt::Long; + $p = new Getopt::Long::Parser; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... + +Configuration options can be passed to the constructor: + + $p = new Getopt::Long::Parser + config => [...configuration options...]; + +For thread safety, each method call will acquire an exclusive lock to +the Getopt::Long module. So don't call these methods from a callback +routine! + =head2 Documentation and help texts Getopt::Long encourages the use of Pod::Usage to produce help @@ -1365,7 +1520,7 @@ options, -vax -would set C, C and C, but +would set C, C and C, but --vax @@ -1423,8 +1578,8 @@ When applied to the following command line: arg1 --width=72 arg2 --width=60 arg3 -This will call -C while C<$width> is C<80>, +This will call +C while C<$width> is C<80>, C while C<$width> is C<72>, and C while C<$width> is C<60>. @@ -1436,10 +1591,15 @@ L. Getopt::Long can be configured by calling subroutine Getopt::Long::Configure(). This subroutine takes a list of quoted -strings, each specifying a configuration option to be set, e.g. -C, or reset, e.g. C. Case does not +strings, each specifying a configuration option to be enabled, e.g. +C, or disabled, e.g. C. Case does not matter. Multiple calls to Configure() are possible. +Alternatively, as of version 2.24, the configuration options may be +passed together with the C statement: + + use Getopt::Long qw(:config no_ignore_case bundling); + The following options are available: =over 12 @@ -1449,34 +1609,53 @@ The following options are available: This option causes all configuration options to be reset to their default values. +=item posix_default + +This option causes all configuration options to be reset to their +default values as if the environment variable POSIXLY_CORRECT had +been set. + =item auto_abbrev Allow option names to be abbreviated to uniqueness. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. =item getopt_compat Allow C<+> to start options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. + +=item gnu_compat + +C controls whether C<--opt=> is allowed, and what it should +do. Without C, C<--opt=> gives an error. With C, +C<--opt=> will give option C and empty value. +This is the way GNU getopt_long() does it. + +=item gnu_getopt + +This is a short way of setting C C C +C. With C, command line handling should be +fully compatible with GNU getopt_long(). =item require_order Whether command line arguments are allowed to be mixed with options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C is reset. +Default is disabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is enabled. See also C, which is the opposite of C. =item permute Whether command line arguments are allowed to be mixed with options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case C is reset. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. Note that C is the opposite of C. -If C is set, this means that +If C is enabled, this means that --foo arg1 --bar arg2 arg3 @@ -1493,7 +1672,7 @@ processed. The only exception is when C<--> is used: will call the call-back routine for arg1 and arg2, and terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. -If C is set, options processing +If C is enabled, options processing terminates when the first non-option is encountered. --foo arg1 --bar arg2 arg3 @@ -1502,40 +1681,40 @@ is equivalent to --foo -- arg1 --bar arg2 arg3 -=item bundling (default: reset) +=item bundling (default: disabled) -Setting this option will allow single-character options to be bundled. +Enabling this option will allow single-character options to be bundled. To distinguish bundles from long option names, long options I be introduced with C<--> and single-character options (and bundles) with C<->. -Note: resetting C also resets C. +Note: disabling C also disables C. -=item bundling_override (default: reset) +=item bundling_override (default: disabled) -If C is set, bundling is enabled as with -C but now long option names override option bundles. +If C is enabled, bundling is enabled as with +C but now long option names override option bundles. -Note: resetting C also resets C. +Note: disabling C also disables C. B Using option bundling can easily lead to unexpected results, especially when mixing long options and bundles. Caveat emptor. -=item ignore_case (default: set) +=item ignore_case (default: enabled) -If set, case is ignored when matching long option names. Single +If enabled, case is ignored when matching long option names. Single character options will be treated case-sensitive. -Note: resetting C also resets C. +Note: disabling C also disables C. -=item ignore_case_always (default: reset) +=item ignore_case_always (default: disabled) When bundling is in effect, case is ignored on single-character -options also. +options also. -Note: resetting C also resets C. +Note: disabling C also disables C. -=item pass_through (default: reset) +=item pass_through (default: disabled) Options that are unknown, ambiguous or supplied with an invalid option value are passed through in C<@ARGV> instead of being flagged as @@ -1543,7 +1722,7 @@ errors. This makes it possible to write wrapper scripts that process only part of the user supplied command line arguments, and pass the remaining options to some other program. -This can be very confusing, especially when C is also set. +This can be very confusing, especially when C is also enabled. =item prefix @@ -1556,9 +1735,9 @@ A Perl pattern that identifies the strings that introduce options. Default is C<(--|-|\+)> unless environment variable POSIXLY_CORRECT has been set, in which case it is C<(--|-)>. -=item debug (default: reset) +=item debug (default: disabled) -Enable copious debugging output. +Enable debugging output. =back @@ -1569,11 +1748,10 @@ signalled using die() and will terminate the calling program unless the call to Getopt::Long::GetOptions() was embedded in C, or die() was trapped using C<$SIG{__DIE__}>. -A return value of 1 (true) indicates success. - -A return status of 0 (false) indicates that the function detected one -or more errors during option parsing. These errors are signalled using -warn() and can be trapped with C<$SIG{__WARN__}>. +GetOptions returns true to indicate success. +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(). @@ -1629,21 +1807,44 @@ Now the command line may look like: Note that to terminate options processing still requires a double dash C<-->. -GetOptions() will not interpret a leading C<"<>"> as option starters -if the next argument is a reference. To force C<"<"> and C<">"> as -option starters, use C<"><">. Confusing? Well, B" >> as option starters +if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as +option starters, use C<< "><" >>. Confusing? Well, B anyway. =head2 Configuration variables Previous versions of Getopt::Long used variables for the purpose of -configuring. Although manipulating these variables still work, it -is strongly encouraged to use the new C routine. Besides, it -is much easier. +configuring. Although manipulating these variables still work, it is +strongly encouraged to use the C routine that was introduced +in version 2.17. Besides, it is much easier. + +=head1 Trouble Shooting + +=head2 Warning: Ignoring '!' modifier for short option + +This warning is issued when the '!' modifier is applied to a short +(one-character) option and bundling is in effect. E.g., + + Getopt::Long::Configure("bundling"); + GetOptions("foo|f!" => \$foo); + +Note that older Getopt::Long versions did not issue a warning, because +the '!' modifier was applied to the first name only. This bug was +fixed in 2.22. + +Solution: separate the long and short names and apply the '!' to the +long names only, e.g., + + GetOptions("foo!" => \$foo, "f" => \$foo); + +=head2 GetOptions does not return a false result when an option is not supplied + +That's why they're called 'options'. =head1 AUTHOR -Johan Vromans Ejvromans@squirrel.nlE +Johan Vromans =head1 COPYRIGHT AND DISCLAIMER @@ -1660,7 +1861,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. If you do not have a copy of the GNU General Public License write to -the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =cut