X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FGetopt%2FLong.pm;h=0f2fa5a16ada62de8766ee6e9da5dd9f1e3a8f9a;hb=c7bcd97d6f3cca0cdeda5b0e9eabe2b3fcca0c57;hp=1966ef3c9117f757825e560c0e61c356e4310b82;hpb=4d512309996fa63a1292d88a28def9af42711464;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 1966ef3..0f2fa5a 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -1,47 +1,59 @@ -# GetOpt::Long.pm -- Universal options parsing +# Getopt::Long.pm -- Universal options parsing package Getopt::Long; -# RCS Status : $Id: GetoptLong.pl,v 2.18 1998-06-14 15:02:19+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.68 2003-09-23 15:24:53+02 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sun Jun 14 13:17:22 1998 -# Update Count : 705 +# Last Modified On: Tue Sep 23 15:21:23 2003 +# Update Count : 1364 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1998 by Johan Vromans. +# This program is Copyright 1990,2002 by Johan Vromans. # This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# +# modify it under the terms of the Perl Artistic License or the +# GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # 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. ################ Module Preamble ################ +use 5.004; + use strict; +use vars qw($VERSION); +$VERSION = 2.34; +# For testing versions only. +#use vars qw($VERSION_STRING); +#$VERSION_STRING = "2.33_03"; + +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK); +@ISA = qw(Exporter); + +# Exported subroutines. +sub GetOptions(@); # always +sub Configure(@); # on demand +sub HelpMessage(@); # on demand +sub VersionMessage(@); # in demand + BEGIN { - require 5.004; - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = "2.17"; - - @ISA = qw(Exporter); - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - %EXPORT_TAGS = qw(); - @EXPORT_OK = qw(); - use AutoLoader qw(AUTOLOAD); + # 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(&HelpMessage &VersionMessage &Configure); } # User visible variables. @@ -51,23 +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); +use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version); -# Public subroutines. -sub Configure (@); -sub config (@); # deprecated name -sub GetOptions; +# Public subroutines. +sub config(@); # deprecated name -# Private subroutines. -sub ConfigDefaults (); -sub FindOption ($$$$$$$); -sub Croak (@); # demand loading the real Croak +# Private subroutines. +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 = "(--|-)"; @@ -88,6 +104,28 @@ 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; + push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions + $pkg->SUPER::import(@syms); + # And configure. + Configure(@config) if @config; } ################ Initialization ################ @@ -97,66 +135,158 @@ sub ConfigDefaults () { # Version major/minor numbers. ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; -# Set defaults. -ConfigDefaults (); +ConfigDefaults(); -################ Package return ################ +################ OO Interface ################ -1; +package Getopt::Long::Parser; -__END__ +# 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 { + Getopt::Long::Configure () +}; -################ AutoLoading subroutines ################ +sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; -# RCS Status : $Id: GetoptLongAl.pl,v 2.20 1998-06-14 15:02:19+02 jv Exp $ -# Author : Johan Vromans -# Created On : Fri Mar 27 11:50:30 1998 -# Last Modified By: Johan Vromans -# Last Modified On: Sun Jun 14 13:54:35 1998 -# Update Count : 24 -# Status : Released + # Register the callers package. + my $self = { caller_pkg => (caller)[0] }; -sub GetOptions { + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + 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 + die(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))."\n"); + } + + $self; +} + +sub configure { + my ($self) = shift; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Getopt::Long::Configure ($save); +} + +sub getoptions { + my ($self) = shift; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller_pkg}; + + eval { + # Locally set exception handler to default, otherwise it will + # be called implicitly here, and again explicitly when we try + # to deliver the messages. + local ($SIG{__DIE__}) = '__DEFAULT__'; + $ret = Getopt::Long::GetOptions (@_); + }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; +} + +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_TYPE_FLAG => ''; +#use constant CTL_TYPE_NEG => '!'; +#use constant CTL_TYPE_INCR => '+'; +#use constant CTL_TYPE_INT => 'i'; +#use constant CTL_TYPE_INTINC => 'I'; +#use constant CTL_TYPE_XINT => 'o'; +#use constant CTL_TYPE_FLOAT => 'f'; +#use constant CTL_TYPE_STRING => 's'; + +use constant CTL_CNAME => 1; + +use constant CTL_MAND => 2; + +use constant CTL_DEST => 3; + use constant CTL_DEST_SCALAR => 0; + use constant CTL_DEST_ARRAY => 1; + use constant CTL_DEST_HASH => 2; + use constant CTL_DEST_CODE => 3; + +use constant CTL_DEFAULT => 4; + +# FFU. +#use constant CTL_RANGE => ; +#use constant CTL_REPEAT => ; + +sub GetOptions(@) { my @optionlist = @_; # local copy of the option descriptions my $argend = '--'; # option list terminator - my %opctl = (); # table of arg.specs (long and abbrevs) - my %bopctl = (); # table of arg.specs (bundles) - my $pkg = (caller)[0]; # current context + my %opctl = (); # table of option specs + my $pkg = $caller || (caller)[0]; # current context # Needed if linkage is omitted. - my %aliases= (); # alias table my @ret = (); # accum for non-options my %linkage; # linkage my $userlinkage; # user supplied HASH my $opt; # current option - my $genprefix = $genprefix; # so we can call the same module many times - my @opctl; # the possible long option names + my $prefix = $genprefix; # current prefix $error = ''; - print STDERR ("GetOpt::Long $Getopt::Long::VERSION ", - "called from package \"$pkg\".", - "\n ", - 'GetOptionsAl $Revision: 2.20 $ ', - "\n ", - "ARGV: (@ARGV)", - "\n ", - "autoabbrev=$autoabbrev,". - "bundling=$bundling,", - "getopt_compat=$getopt_compat,", - "order=$order,", - "\n ", - "ignorecase=$ignorecase,", - "passthrough=$passthrough,", - "genprefix=\"$genprefix\".", - "\n") - if $debug; - - # Check for ref HASH as first argument. + if ( $debug ) { + # Avoid some warnings if debugging. + local ($^W) = 0; + print STDERR + ("Getopt::Long $Getopt::Long::VERSION (", + '$Revision: 2.68 $', ") ", + "called from package \"$pkg\".", + "\n ", + "ARGV: (@ARGV)", + "\n ", + "autoabbrev=$autoabbrev,". + "bundling=$bundling,", + "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", + "order=$order,", + "\n ", + "ignorecase=$ignorecase,", + "requested_version=$requested_version,", + "passthrough=$passthrough,", + "genprefix=\"$genprefix\".", + "\n"); + } + + # Check for ref HASH as first argument. # First argument may be an object. It's OK to use this as long - # as it is really a hash underneath. + # as it is really a hash underneath. $userlinkage = undef; - if ( ref($optionlist[0]) and + if ( @optionlist && ref($optionlist[0]) and "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) { $userlinkage = shift (@optionlist); print STDERR ("=> user linkage: $userlinkage\n") if $debug; @@ -164,21 +294,25 @@ sub GetOptions { # See if the first element of the optionlist contains option # starter characters. - if ( $optionlist[0] =~ /^\W+$/ ) { - $genprefix = shift (@optionlist); + # Be careful not to interpret '<>' as option starters. + if ( @optionlist && $optionlist[0] =~ /^\W+$/ + && !($optionlist[0] eq '<>' + && @optionlist > 0 + && ref($optionlist[1])) ) { + $prefix = shift (@optionlist); # Turn into regexp. Needs to be parenthesized! - $genprefix =~ s/(\W)/\\$1/g; - $genprefix = "([" . $genprefix . "])"; + $prefix =~ s/(\W)/\\$1/g; + $prefix = "([" . $prefix . "])"; + print STDERR ("=> prefix=\"$prefix\"\n") if $debug; } # Verify correctness of optionlist. %opctl = (); - %bopctl = (); - while ( @optionlist > 0 ) { + while ( @optionlist ) { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; + $opt = $+ if $opt =~ /^$prefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -187,77 +321,39 @@ sub GetOptions { && ref($userlinkage->{$opt}) ) { unshift (@optionlist, $userlinkage->{$opt}); } - unless ( @optionlist > 0 + unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { $error .= "Option spec <> requires a reference to a subroutine\n"; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); next; } $linkage{'<>'} = shift (@optionlist); next; } - # Match option spec. Allow '?' as an alias. - if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) { - $error .= "Error in option spec: \"$opt\"\n"; + # Parse option spec. + my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); + unless ( defined $name ) { + # Failed. $orig contains the error message. Sorry for the abuse. + $error .= $orig; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); next; } - my ($o, $c, $a) = ($1, $5); - $c = '' unless defined $c; - - if ( ! defined $o ) { - # empty -> '-' option - $opctl{$o = ''} = $c; - } - else { - # Handle alias names - my @o = split (/\|/, $o); - my $linko = $o = $o[0]; - # Force an alias if the option name is not locase. - $a = $o unless $o eq lc($o); - $o = lc ($o) - if $ignorecase > 1 - || ($ignorecase - && ($bundling ? length($o) > 1 : 1)); - - foreach ( @o ) { - if ( $bundling && length($_) == 1 ) { - $_ = lc ($_) if $ignorecase > 1; - if ( $c eq '!' ) { - $opctl{"no$_"} = $c; - warn ("Ignoring '!' modifier for short option $_\n"); - $c = ''; - } - $opctl{$_} = $bopctl{$_} = $c; - } - else { - $_ = lc ($_) if $ignorecase; - if ( $c eq '!' ) { - $opctl{"no$_"} = $c; - $c = ''; - } - $opctl{$_} = $c; - } - if ( defined $a ) { - # Note alias. - $aliases{$_} = $a; - } - else { - # Set primary name. - $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->{$orig} && + ref($userlinkage->{$orig}) ) { + print STDERR ("=> found userlinkage for \"$orig\": ", + "$userlinkage->{$orig}\n") if $debug; - unshift (@optionlist, $userlinkage->{$o}); + unshift (@optionlist, $userlinkage->{$orig}); } else { # Do nothing. Being undefined will be handled later. @@ -268,26 +364,29 @@ 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 \"$orig\" to $optionlist[0]\n") if $debug; - if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) { - $linkage{$o} = shift (@optionlist); + my $rl = ref($linkage{$orig} = shift (@optionlist)); + + if ( $rl eq "ARRAY" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; + } + elsif ( $rl eq "HASH" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; } - elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) { - $linkage{$o} = shift (@optionlist); - $opctl{$o} .= '@' - if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; - $bopctl{$o} .= '@' - if $bundling and defined $bopctl{$o} and - $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + elsif ( $rl eq "SCALAR" ) { +# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { +# my $t = $linkage{$orig}; +# $$t = $linkage{$orig} = []; +# } +# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { +# } +# else { + # Ok. +# } } - elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { - $linkage{$o} = shift (@optionlist); - $opctl{$o} .= '%' - if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; - $bopctl{$o} .= '%' - if $bundling and defined $bopctl{$o} and - $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; + elsif ( $rl eq "CODE" ) { + # Ok. } else { $error .= "Invalid option linkage for \"$opt\"\n"; @@ -296,22 +395,22 @@ sub GetOptions { else { # Link to global $opt_XXX variable. # Make sure a valid perl identifier results. - my $ov = $o; + my $ov = $orig; $ov =~ s/\W/_/g; - if ( $c =~ /@/ ) { - print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n") + if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); } - elsif ( $c =~ /%/ ) { - print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n") + elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); } else { - print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n") + print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") if $debug; - eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;"); + eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); } } } @@ -320,67 +419,74 @@ sub GetOptions { die ($error) if $error; $error = 0; - # Sort the possible long option names. - @opctl = sort(keys (%opctl)) if $autoabbrev; + # 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; + } + $auto_version = 1; + } + 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; + } + $auto_help = 1; + } # Show the options tables if debugging. if ( $debug ) { my ($arrow, $k, $v); $arrow = "=> "; while ( ($k,$v) = each(%opctl) ) { - print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); - $arrow = " "; - } - $arrow = "=> "; - while ( ($k,$v) = each(%bopctl) ) { - print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n"); + print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); $arrow = " "; } } # Process argument list - while ( @ARGV > 0 ) { - - #### Get next argument #### + my $goon = 1; + while ( $goon && @ARGV > 0 ) { + # Get next argument. $opt = shift (@ARGV); - print STDERR ("=> option \"", $opt, "\"\n") if $debug; - - #### Determine what we have #### + print STDERR ("=> arg \"", $opt, "\"\n") if $debug; # Double dash is option list terminator. if ( $opt eq $argend ) { - # Finish. Push back accumulated arguments and return. - unshift (@ARGV, @ret) - if $order == $PERMUTE; - return ($error == 0); + push (@ret, $argend) if $passthrough; + last; } + # Look it up. my $tryopt = $opt; my $found; # success status - my $dsttype; # destination type ('@' or '%') - my $incr; # destination increment my $key; # key (if hash type) my $arg; # option argument + my $ctl; # the opctl entry - ($found, $opt, $arg, $dsttype, $incr, $key) = - FindOption ($genprefix, $argend, $opt, - \%opctl, \%bopctl, \@opctl, \%aliases); + ($found, $opt, $ctl, $arg, $key) = + FindOption ($prefix, $argend, $opt, \%opctl); if ( $found ) { - + # FindOption undefines $opt in case of errors. next unless defined $opt; if ( defined $arg ) { - $opt = $aliases{$opt} if defined $aliases{$opt}; + + # Get the canonical name. + print STDERR ("=> cname for \"$opt\" is ") if $debug; + $opt = $ctl->[CTL_CNAME]; + print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; if ( defined $linkage{$opt} ) { print STDERR ("=> ref(\$L{$opt}) -> ", ref($linkage{$opt}), "\n") if $debug; if ( ref($linkage{$opt}) eq 'SCALAR' ) { - if ( $incr ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") if $debug; if ( defined ${$linkage{$opt}} ) { @@ -390,6 +496,26 @@ sub GetOptions { ${$linkage{$opt}} = $arg; } } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to ARRAY\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = []; + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to HASH\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = {}; + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } else { print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug; @@ -407,18 +533,40 @@ sub GetOptions { $linkage{$opt}->{$key} = $arg; } elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n") + print STDERR ("=> &L{$opt}(\"$opt\"", + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", + ", \"$arg\")\n") if $debug; - &{$linkage{$opt}}($opt, $arg); + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { + &{$linkage{$opt}}($opt, + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), + $arg); + }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } } else { print STDERR ("Invalid REF type \"", ref($linkage{$opt}), "\" in linkage\n"); - Croak ("Getopt::Long -- internal error!\n"); + die("Getopt::Long -- internal error!\n"); } } # No entry in linkage means entry in userlinkage. - elsif ( $dsttype eq '@' ) { + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") if $debug; @@ -430,7 +578,7 @@ sub GetOptions { $userlinkage->{$opt} = [$arg]; } } - elsif ( $dsttype eq '%' ) { + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { if ( defined $userlinkage->{$opt} ) { print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") if $debug; @@ -443,7 +591,7 @@ sub GetOptions { } } else { - if ( $incr ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { print STDERR ("=> \$L{$opt} += \"$arg\"\n") if $debug; if ( defined $userlinkage->{$opt} ) { @@ -466,7 +614,25 @@ sub GetOptions { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb ($tryopt); + print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { &$cb ($tryopt) }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } } else { print STDERR ("=> saving \"$tryopt\" ", @@ -486,102 +652,234 @@ sub GetOptions { } # Finish. - if ( $order == $PERMUTE ) { + if ( @ret && $order == $PERMUTE ) { # Push back accumulated arguments print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") - if $debug && @ret > 0; - unshift (@ARGV, @ret) if @ret > 0; + if $debug; + unshift (@ARGV, @ret); } return ($error == 0); } +# A readable representation of what's in an optbl. +sub OptCtl ($) { + my ($v) = @_; + my @v = map { defined($_) ? ($_) : ("") } @$v; + "[". + join(",", + "\"$v[CTL_TYPE]\"", + "\"$v[CTL_CNAME]\"", + $v[CTL_MAND] ? "O" : "M", + ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], + "\"$v[CTL_DEFAULT]\"", +# $v[CTL_RANGE] || '', +# $v[CTL_REPEAT] || '', + ). "]"; +} + +# Parse an option specification and fill the tables. +sub ParseOptionSpec ($$) { + my ($opt, $opctl) = @_; + + # Match option spec. + if ( $opt !~ m;^ + ( + # Option name + (?: \w+[-\w]* ) + # Alias names, or "?" + (?: \| (?: \? | \w[-\w]* )? )* + )? + ( + # Either modifiers ... + [!+] + | + # ... or a value/dest specification + [=:] [ionfs] [@%]? + | + # ... or an optional-with-default spec + : (?: -?\d+ | \+ ) [@%]? + )? + $;x ) { + return (undef, "Error in option spec: \"$opt\"\n"); + } + + my ($names, $spec) = ($1, $2); + $spec = '' unless defined $spec; + + # $orig 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 $orig; + + my @names; + if ( defined $names ) { + @names = split (/\|/, $names); + $orig = $names[0]; + } + else { + @names = (''); + $orig = ''; + } + + # Construct the opctl entries. + my $entry; + if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { + # Fields are hard-wired here. + $entry = [$spec,$orig,0,CTL_DEST_SCALAR,undef]; + } + elsif ( $spec =~ /:(-?\d+|\+)([@%])?/ ) { + my $def = $1; + my $dest = $2; + my $type = $def eq '+' ? 'I' : 'i'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,0,$dest,$def eq '+' ? undef : $def]; + } + else { + my ($mand, $type, $dest) = $spec =~ /([=:])([ionfs])([@%])?/; + $type = 'i' if $type eq 'n'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,$mand eq '=',$dest,undef]; + } + + # Process all names. First is canonical, the rest are aliases. + my $dups = ''; + foreach ( @names ) { + + $_ = lc ($_) + if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + + if ( exists $opctl->{$_} ) { + $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; + } + + if ( $spec eq '!' ) { + $opctl->{"no$_"} = $entry; + $opctl->{"no-$_"} = $entry; + $opctl->{$_} = [@$entry]; + $opctl->{$_}->[CTL_TYPE] = ''; + } + else { + $opctl->{$_} = $entry; + } + } + + if ( $dups && $^W ) { + foreach ( split(/\n+/, $dups) ) { + warn($_."\n"); + } + } + ($names[0], $orig); +} + # Option lookup. -sub FindOption ($$$$$$$) { +sub FindOption ($$$$) { - # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay, + # returns (1, $opt, $ctl, $arg, $key) if okay, + # returns (1, undef) if option in error, # returns (0) otherwise. - my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_; - my $key; # hash key for a hash option - my $arg; + my ($prefix, $argend, $opt, $opctl) = @_; - print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug; + print STDERR ("=> find \"$opt\"\n") if $debug; return (0) unless $opt =~ /^$prefix(.*)$/s; + return (0) if $opt eq "-" && !defined $opctl->{''}; $opt = $+; - my ($starter) = $1; + my $starter = $1; print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; - my $optarg = undef; # value supplied with --opt=value - my $rest = undef; # remainder from unbundling + my $optarg; # value supplied with --opt=value + my $rest; # remainder from unbundling # If it is a long option, it may include the value. - if (($starter eq "--" || ($getopt_compat && !$bundling)) - && $opt =~ /^([^=]+)=(.*)$/s ) { + # With getopt_compat, only if not bundling. + if ( ($starter eq "--" + || ($getopt_compat && ($bundling == 0 || $bundling == 2))) + && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; $optarg = $2; - print STDERR ("=> option \"", $opt, + print STDERR ("=> option \"", $opt, "\", optarg = \"$optarg\"\n") if $debug; } #### Look it up ### my $tryopt = $opt; # option to try - my $optbl = $opctl; # table to look it up (long names) - my $type; - my $dsttype = ''; - my $incr = 0; if ( $bundling && $starter eq '-' ) { - # Unbundle single letter option. - $rest = substr ($tryopt, 1); - $tryopt = substr ($tryopt, 0, 1); - $tryopt = lc ($tryopt) if $ignorecase > 1; - print STDERR ("=> $starter$tryopt unbundled from ", - "$starter$tryopt$rest\n") if $debug; - $rest = undef unless $rest ne ''; - $optbl = $bopctl; # look it up in the short names table + + # To try overrides, obey case ignore. + $tryopt = $ignorecase ? lc($opt) : $opt; # If bundling == 2, long options can override bundles. - if ( $bundling == 2 and - defined ($type = $opctl->{$tryopt.$rest}) ) { - print STDERR ("=> $starter$tryopt rebundled to ", + if ( $bundling == 2 && length($tryopt) > 1 + && defined ($opctl->{$tryopt}) ) { + print STDERR ("=> $starter$tryopt overrides unbundling\n") + if $debug; + } + else { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", "$starter$tryopt$rest\n") if $debug; - $tryopt .= $rest; - undef $rest; + $rest = undef unless $rest ne ''; } - } + } # Try auto-abbreviation. elsif ( $autoabbrev ) { + # Sort the possible long option names. + my @names = sort(keys (%$opctl)); # Downcase if allowed. - $tryopt = $opt = lc ($opt) if $ignorecase; + $opt = lc ($opt) if $ignorecase; + $tryopt = $opt; # Turn option name into pattern. my $pat = quotemeta ($opt); # Look up in option names. - my @hits = grep (/^$pat/, @{$names}); + my @hits = grep (/^$pat/, @names); print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", - "out of ", scalar(@{$names}), "\n") if $debug; + "out of ", scalar(@names), "\n") if $debug; # Check for ambiguous results. unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { # See if all matches are for the same option. my %hit; foreach ( @hits ) { - $_ = $aliases->{$_} if defined $aliases->{$_}; + $_ = $opctl->{$_}->[CTL_CNAME] + if defined $opctl->{$_}->[CTL_CNAME]; $hit{$_} = 1; } + # Remove auto-supplied options (version, help). + if ( keys(%hit) == 2 ) { + if ( $auto_version && exists($hit{version}) ) { + delete $hit{version}; + } + elsif ( $auto_help && exists($hit{help}) ) { + delete $hit{help}; + } + } # Now see if it really is ambiguous. unless ( keys(%hit) == 1 ) { return (0) if $passthrough; warn ("Option ", $opt, " is ambiguous (", join(", ", @hits), ")\n"); $error++; - undef $opt; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, undef); } @hits = keys(%hit); } @@ -601,20 +899,29 @@ sub FindOption ($$$$$$$) { } # Check validity by fetching the info. - $type = $optbl->{$tryopt} unless defined $type; - unless ( defined $type ) { + my $ctl = $opctl->{$tryopt}; + unless ( defined $ctl ) { return (0) if $passthrough; + # Pretend one char when bundling. + if ( $bundling == 1) { + $opt = substr($opt,0,1); + unshift (@ARGV, $starter.$rest) if defined $rest; + } warn ("Unknown option: ", $opt, "\n"); $error++; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, undef); } # Apparently valid. $opt = $tryopt; - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + print STDERR ("=> found ", OptCtl($ctl), + " for \"", $opt, "\"\n") if $debug; #### Determine argument status #### # If it is an option w/o argument, we're almost finished with it. + my $type = $ctl->[CTL_TYPE]; + my $arg; + if ( $type eq '' || $type eq '!' || $type eq '+' ) { if ( defined $optarg ) { return (0) if $passthrough; @@ -623,35 +930,46 @@ sub FindOption ($$$$$$$) { undef $opt; } elsif ( $type eq '' || $type eq '+' ) { - $arg = 1; # supply explicit value - $incr = $type eq '+'; + # Supply explicit value. + $arg = 1; } else { - substr ($opt, 0, 2) = ''; # strip NO prefix + $opt =~ s/^no-?//i; # strip NO prefix $arg = 0; # supply explicit value } unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, $opt, $ctl, $arg); } # Get mandatory status and type info. - my $mand; - ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/; + my $mand = $ctl->[CTL_MAND]; + + # Check if there is an option argument available. + if ( $gnu_compat && defined $optarg && $optarg eq '' ) { + return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand; + $optarg = 0 unless $type eq 's'; + } # Check if there is an option argument available. - if ( defined $optarg ? ($optarg eq '') + if ( defined $optarg + ? ($optarg eq '') : !(defined $rest || @ARGV > 0) ) { # Complain if this option needs an argument. - if ( $mand eq "=" ) { + if ( $mand ) { return (0) if $passthrough; warn ("Option ", $opt, " requires an argument\n"); $error++; - undef $opt; + return (1, undef); } - if ( $mand eq ":" ) { - $arg = $type eq "s" ? '' : 0; + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); } - return (1, $opt,$arg,$dsttype,$incr,$key); + return (1, $opt, $ctl, + defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + $type eq 's' ? '' : 0); } # Get (possibly optional) argument. @@ -659,21 +977,32 @@ sub FindOption ($$$$$$$) { : (defined $optarg ? $optarg : shift (@ARGV))); # Get key if this is a "name=value" pair for a hash option. - $key = undef; - if ($dsttype eq '%' && defined $arg) { - ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1); + 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] : + ($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 #### - if ( $type eq "s" ) { # string - # A mandatory string takes anything. - return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "="; + my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; - # An optional string takes almost anything. - return (1, $opt,$arg,$dsttype,$incr,$key) + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1, $opt, $ctl, $arg, $key) if $mand; + + # An optional string takes almost anything. + return (1, $opt, $ctl, $arg, $key) if defined $optarg || defined $rest; - return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ?? + return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? # Check for option or option list terminator. if ($arg eq $argend || @@ -685,47 +1014,67 @@ sub FindOption ($$$$$$$) { } } - elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) { - $arg = $1; - $rest = $2; + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" + : "[-+]?[0-9]+"; + + 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 ''; } - elsif ( $arg !~ /^-?[0-9]+$/ ) { - if ( defined $optarg || $mand eq "=" ) { + elsif ( $arg =~ /^($o_valid)$/si ) { + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + } + else { + if ( defined $optarg || $mand ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; return (0); } warn ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); + $opt, " (", + $type eq 'o' ? "extended " : '', + "number expected)\n"); $error++; - undef $opt; # Push back. unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); } else { # Push back. unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } # Supply default value. - $arg = 0; + $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; } } } - elsif ( $type eq "f" ) { # real number, int is also ok + elsif ( $type eq 'f' ) { # real number, int is also ok # We require at least one digit before a point or 'e', # 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]+)?$/ ) { - if ( defined $optarg || $mand eq "=" ) { + elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { + if ( defined $optarg || $mand ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; @@ -734,9 +1083,9 @@ sub FindOption ($$$$$$$) { warn ("Value \"", $arg, "\" invalid for option ", $opt, " (real number expected)\n"); $error++; - undef $opt; # Push back. unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); } else { # Push back. @@ -747,14 +1096,27 @@ sub FindOption ($$$$$$$) { } } else { - Croak ("GetOpt::Long internal error (Can't happen)\n"); + die("Getopt::Long internal error (Can't happen)\n"); } - return (1, $opt, $arg, $dsttype, $incr, $key); + return (1, $opt, $ctl, $arg, $key); } # Getopt::Long Configuration. sub Configure (@) { my (@options) = @_; + + my $prevconfig = + [ $error, $debug, $major_version, $minor_version, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $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, $auto_version, $auto_help ) = + @{shift(@options)}; + } + my $opt; foreach $opt ( @options ) { my $try = lc ($opt); @@ -763,8 +1125,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; @@ -772,6 +1139,23 @@ 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; + $order = $PERMUTE; + } + } + 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; } @@ -793,28 +1177,29 @@ 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 $@; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; } - elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { $genprefix = $1; # Parenthesize if needed. - $genprefix = "(" . $genprefix . ")" + $genprefix = "(" . $genprefix . ")" unless $genprefix =~ /^\(.*\)$/; eval { '' =~ /$genprefix/; }; - Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; } elsif ( $try eq 'debug' ) { $debug = $action; } else { - Croak ("Getopt::Long: unknown config parameter \"$opt\"") + die("Getopt::Long: unknown config parameter \"$opt\"") } } + $prevconfig; } # Deprecated name. @@ -822,23 +1207,116 @@ sub config (@) { Configure (@_); } -# To prevent Carp from being loaded unnecessarily. -sub Croak (@) { - require 'Carp.pm'; - $Carp::CarpLevel = 1; - Carp::croak(@_); -}; +# 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($Getopt::Long::VERSION_STRING) + ? $Getopt::Long::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 -GetOptions - extended processing of command line options +Getopt::Long - Extended processing of command line options =head1 SYNOPSIS use Getopt::Long; - $result = GetOptions (...option-descriptions...); + my $data = "file.dat"; + my $length = 24; + my $verbose; + $result = GetOptions ("length=i" => \$length, # numeric + "file=s" => \$data, # string + "verbose" => \$verbose); # flag =head1 DESCRIPTION @@ -848,350 +1326,605 @@ line options, with GNU extensions. In general, this means that options have long names instead of single letters, and are introduced with a double dash "--". Support for bundling of command line options, as was the case with the more traditional single-letter approach, is provided -but not enabled by default. For example, the UNIX "ps" command can be -given the command line "option" +but not enabled by default. + +=head1 Command Line Options, an Introduction + +Command line operated programs traditionally take their arguments from +the command line, for example filenames or other information that the +program needs to know. Besides arguments, these programs often take +command line I as well. Options are not necessary for the +program to work, hence the name 'option', but are used to modify its +default behaviour. For example, a program could do its job quietly, +but with a suitable option it could provide verbose information about +what it did. + +Command line options come in several flavours. Historically, they are +preceded by a single dash C<->, and consist of a single letter. + + -l -a -c + +Usually, these single-character options can be bundled: + + -lac + +Options can have values, the value is placed after the option +character. Sometimes with whitespace in between, sometimes not: + + -s 24 -s24 + +Due to the very cryptic nature of these options, another style was +developed that used long names. So instead of a cryptic C<-l> one +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 + + --size=24 + +or - -vax + --size 24 -which means the combination of B<-v>, B<-a> and B<-x>. With the new -syntax B<--vax> would be a single option, probably indicating a -computer architecture. +The C<+> form is now obsolete and strongly deprecated. -Command line options can be used to set values. These values can be -specified in one of two ways: +=head1 Getting Started with Getopt::Long - --size 24 - --size=24 +Getopt::Long is the Perl5 successor of C. This was +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 +characters C and C<->. -GetOptions is called with a list of option-descriptions, each of which -consists of two elements: the option specifier and the option linkage. -The option specifier defines the name of the option and, optionally, -the value it can take. The option linkage is usually a reference to a -variable that will be set when the option is used. For example, the -following call to GetOptions: +To use Getopt::Long from a Perl program, you must include the +following line in your Perl program: - GetOptions("size=i" => \$offset); + use Getopt::Long; -will accept a command line option "size" that must have an integer -value. With a command line of "--size 24" this will cause the variable -$offset to get the value 24. +This will load the core of the Getopt::Long module and prepare your +program for using it. Most of the actual Getopt::Long code is not +loaded until you really call one of its functions. -Alternatively, the first argument to GetOptions may be a reference to -a HASH describing the linkage for the options, or an object whose -class is based on a HASH. The following call is equivalent to the -example above: +In the default configuration, options names may be abbreviated to +uniqueness, case does not matter, and a single dash is sufficient, +even for long option names. Also, options may be placed between +non-option arguments. See L for more +details on how to configure Getopt::Long. - %optctl = ("size" => \$offset); - GetOptions(\%optctl, "size=i"); +=head2 Simple options -Linkage may be specified using either of the above methods, or both. -Linkage specified in the argument list takes precedence over the -linkage specified in the HASH. +The most simple options are the ones that take no values. Their mere +presence on the command line enables the option. Popular examples are: -The command line options are taken from array @ARGV. Upon completion -of GetOptions, @ARGV will contain the rest (i.e. the non-options) of -the command line. - -Each option specifier designates the name of the option, optionally -followed by an argument specifier. + --all --verbose --quiet --debug -Options that do not take arguments will have no argument specifier. -The option variable will be set to 1 if the option is used. +Handling simple options is straightforward: -For the other options, the values for argument specifiers are: + my $verbose = ''; # option variable with default value (false) + my $all = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, 'all' => \$all); -=over 8 +The call to GetOptions() parses the command line arguments that are +present in C<@ARGV> and sets the option variable to the value C<1> if +the option did occur on the command line. Otherwise, the option +variable is not touched. Setting the option value to true is often +called I the option. + +The option name as specified to the GetOptions() function is called +the option I. Later we'll see that this specification +can contain more than just the option name. The reference to the +variable is called the option I. + +GetOptions() will return a true value if the command line could be +processed successfully. Otherwise, it will write error messages to +STDERR, and return a false result. + +=head2 A little bit less simple options + +Getopt::Long supports two useful variants of simple options: +I options and I options. + +A negatable option is specified with an exclamation mark C after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose!' => \$verbose); + +Now, using C<--verbose> on the command line will enable C<$verbose>, +as expected. But it is also allowed to use C<--noverbose>, which will +disable C<$verbose> by setting its value to C<0>. Using a suitable +default value, the program can find out whether C<$verbose> is false +by default, or disabled by using C<--noverbose>. + +An incremental option is specified with a plus C<+> after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose+' => \$verbose); + +Using C<--verbose> on the command line will increment the value of +C<$verbose>. This way the program can keep track of how many times the +option occurred on the command line. For example, each occurrence of +C<--verbose> could increase the verbosity level of the program. + +=head2 Mixing command line option with other arguments + +Usually programs take command line options as well as other arguments, +for example, file names. It is good practice to always specify the +options first, and the other arguments last. Getopt::Long will, +however, allow the options and arguments to be mixed and 'filter out' +all the options before passing the rest of the arguments to the +program. To stop Getopt::Long from processing further arguments, +insert a double dash C<--> on the command line: + + --size 24 -- --all + +In this example, C<--all> will I be treated as an option, but +passed to the program unharmed, in C<@ARGV>. + +=head2 Options with values + +For options that take values it must be specified whether the option +value is required or not, and what kind of value the option expects. + +Three kinds of values are supported: integer numbers, floating point +numbers, and strings. + +If the option value is required, Getopt::Long will take the +command line argument that follows the option and assign this to the +option variable. If, however, the option value is specified as +optional, this will only be done if that value does not look like a +valid command line option itself. + + my $tag = ''; # option variable with default value + GetOptions ('tag=s' => \$tag); + +In the option specification, the option name is followed by an equals +sign C<=> and the letter C. The equals sign indicates that this +option requires a value. The letter C indicates that this value is +an arbitrary string. Other possible value types are C for integer +values, and C for floating point values. Using a colon C<:> instead +of the equals sign indicates that the option value is optional. In +this case, if no suitable value is supplied, string valued options get +an empty string C<''> assigned, while numeric options are set to C<0>. + +=head2 Options with multiple values + +Options sometimes take several values. For example, a program could +use multiple directories to search for library files: + + --library lib/stdlib --library lib/extlib + +To accomplish this behaviour, simply specify an array reference as the +destination for the option: + + GetOptions ("library=s" => \@libfiles); + +Alternatively, you can specify that the option can have multiple +values by adding a "@", and pass a scalar reference as the +destination: + + GetOptions ("library=s@" => \$libfiles); + +Used with the example above, C<@libfiles> (or C<@$libfiles>) would +contain two strings upon completion: C<"lib/srdlib"> and +C<"lib/extlib">, in that order. It is also possible to specify that +only integer or floating point numbers are acceptible values. + +Often it is useful to allow comma-separated lists of values as well as +multiple occurrences of the options. This is easy using Perl's split() +and join() operators: + + GetOptions ("library=s" => \@libfiles); + @libfiles = split(/,/,join(',',@libfiles)); + +Of course, it is important to choose the right separator string for +each purpose. + +=head2 Options with hash values + +If the option destination is a reference to a hash, the option will +take, as value, strings of the form IC<=>I. The value will +be stored with the specified key in the hash. + + GetOptions ("define=s" => \%defines); + +Alternatively you can use: + + GetOptions ("define=s%" => \$defines); + +When used with command line options: + + --define os=linux --define vendor=redhat + +the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> +with value C<"linux> and C<"vendor"> with value C<"redhat">. It is +also possible to specify that only integer or floating point numbers +are acceptible values. The keys are always taken to be strings. + +=head2 User-defined subroutines to handle options + +Ultimate control over what should be done when (actually: each time) +an option is encountered on the command line can be achieved by +designating a reference to a subroutine (or an anonymous subroutine) +as the option destination. When GetOptions() encounters the option, it +will call the subroutine with two or three arguments. The first +argument is the name of the option. For a scalar or array destination, +the second argument is the value to be stored. For a hash destination, +the second arguments is the key to the hash, and the third argument +the value to be stored. It is up to the subroutine to store the value, +or do whatever it thinks is appropriate. + +A trivial application of this mechanism is to implement options that +are related to each other. For example: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, + 'quiet' => sub { $verbose = 0 }); + +Here C<--verbose> and C<--quiet> control the same variable +C<$verbose>, but with opposite values. + +If the subroutine needs to signal an error, it should call die() with +the desired error message as its argument. GetOptions() will catch the +die(), issue the error message, and record that an error result must +be returned upon completion. + +If the text of the error message starts with an exclamantion mark C +it is interpreted specially by GetOptions(). There is currently one +special command implemented: C will cause GetOptions() +to stop processing options, as if it encountered a double dash C<-->. + +=head2 Options with multiple names + +Often it is user friendly to supply alternate mnemonic names for +options. For example C<--height> could be an alternate name for +C<--length>. Alternate names can be included in the option +specification, separated by vertical bar C<|> characters. To implement +the above example: + + GetOptions ('length|height=f' => \$length); + +The first name is called the I name, the other names are +called I. + +Multiple alternate names are possible. + +=head2 Case and abbreviations + +Without additional configuration, GetOptions() will ignore the case of +option names, and allow the options to be abbreviated to uniqueness. + + GetOptions ('length|height=f' => \$length, "head" => \$head); + +This call will allow C<--l> and C<--L> for the length option, but +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. + +The name specification contains the name of the option, optionally +followed by a list of alternative names separated by vertical bar +characters. + + length option name is "length" + length|size|l name is "length", aliases are "size" and "l" + +The argument specification is optional. If omitted, the option is +considered boolean, a value of 1 will be assigned when the option is +used on the command line. + +The argument specification can be + +=over 4 =item ! -Option does not take an argument and may be negated, i.e. prefixed by -"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> -(with value 0). -The option variable will be set to 1, or 0 if negated. +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> 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 +pointless and will result in a warning. =item + -Option does not take an argument and will be incremented by 1 every -time it appears on the command line. E.g. "more+", when used with -B<--more --more --more>, will set the option variable to 3 (provided -it was 0 or undefined at first). +The option does not take an argument and will be incremented by 1 +every time it appears on the command line. E.g. C<"more+">, when used +with C<--more --more --more>, will increment the value three times, +resulting in a value of 3 (provided it was 0 or undefined at first). -The B<+> specifier is ignored if the option destination is not a SCALAR. +The C<+> specifier is ignored if the option destination is not a scalar. -=item =s +=item = I [ I ] -Option takes a mandatory string argument. -This string will be assigned to the option variable. -Note that even if the string argument starts with B<-> or B<-->, it -will not be considered an option on itself. +The option requires an argument of the given type. Supported types +are: -=item :s +=over 4 -Option takes an optional string argument. -This string will be assigned to the option variable. -If omitted, it will be assigned "" (an empty string). -If the string argument starts with B<-> or B<-->, it -will be considered an option on itself. +=item s -=item =i +String. An arbitrary sequence of characters. It is valid for the +argument to start with C<-> or C<-->. -Option takes a mandatory integer argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. +=item i -=item :i +Integer. An optional leading plus or minus sign, followed by a +sequence of digits. -Option takes an optional integer argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. -Note that the value may start with B<-> to indicate a negative -value. +=item o + +Extended integer, Perl style. This can be either an optional leading +plus or minus sign, followed by a sequence of digits, or an octal +string (a zero, optionally followed by '0', '1', .. '7'), or a +hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case +insensitive), or a binary string (C<0b> followed by a series of '0' +and '1'). + +=item f + +Real number. For example C<3.14>, C<-6.23E24> and so on. + +=back -=item =f +The I can be C<@> or C<%> to specify that the option is +list or a hash valued. This is only needed when the destination for +the option value is not otherwise specified. It should be omitted when +not needed. -Option takes a mandatory real number argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. +=item : I [ I ] -=item :f +Like C<=>, but designates the argument as optional. +If omitted, an empty string will be assigned to string values options, +and the value zero to numeric options. -Option takes an optional real number argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. +Note that if a string argument starts with C<-> or C<-->, it will be +considered an option on itself. + +=item : I [ I ] + +Like C<:i>, but if the value is omitted, the I will be assigned. + +=item : + [ I ] + +Like C<:i>, but if the value is omitted, the current value for the +option will be incremented. =back -A lone dash B<-> is considered an option, the corresponding option -name is the empty string. +=head1 Advanced Possibilities -A double dash on itself B<--> signals end of the options list. +=head2 Object oriented interface -=head2 Linkage specification +Getopt::Long can be used in an object oriented way as well: -The linkage specifier is optional. If no linkage is explicitly -specified but a ref HASH is passed, GetOptions will place the value in -the HASH. For example: + use Getopt::Long; + $p = new Getopt::Long::Parser; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... - %optctl = (); - GetOptions (\%optctl, "size=i"); +Configuration options can be passed to the constructor: -will perform the equivalent of the assignment + $p = new Getopt::Long::Parser + config => [...configuration options...]; - $optctl{"size"} = 24; +=head2 Thread Safety -For array options, a reference to an array is used, e.g.: +Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is +I thread safe when using the older (experimental and now +obsolete) threads implementation that was added to Perl 5.005. - %optctl = (); - GetOptions (\%optctl, "sizes=i@"); +=head2 Documentation and help texts -with command line "-sizes 24 -sizes 48" will perform the equivalent of -the assignment +Getopt::Long encourages the use of Pod::Usage to produce help +messages. For example: - $optctl{"sizes"} = [24, 48]; + use Getopt::Long; + use Pod::Usage; -For hash options (an option whose argument looks like "name=value"), -a reference to a hash is used, e.g.: + my $man = 0; + my $help = 0; - %optctl = (); - GetOptions (\%optctl, "define=s%"); + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-exitstatus => 0, -verbose => 2) if $man; -with command line "--define foo=hello --define bar=world" will perform the -equivalent of the assignment + __END__ - $optctl{"define"} = {foo=>'hello', bar=>'world') + =head1 NAME -If no linkage is explicitly specified and no ref HASH is passed, -GetOptions will put the value in a global variable named after the -option, prefixed by "opt_". To yield a usable Perl variable, -characters that are not part of the syntax for variables are -translated to underscores. For example, "--fpp-struct-return" will set -the variable $opt_fpp_struct_return. Note that this variable resides -in the namespace of the calling program, not necessarily B
. -For example: + sample - Using Getopt::Long and Pod::Usage - GetOptions ("size=i", "sizes=i@"); + =head1 SYNOPSIS -with command line "-size 10 -sizes 24 -sizes 48" will perform the -equivalent of the assignments + sample [options] [file ...] - $opt_size = 10; - @opt_sizes = (24, 48); + Options: + -help brief help message + -man full documentation -A lone dash B<-> is considered an option, the corresponding Perl -identifier is $opt_ . + =head1 OPTIONS -The linkage specifier can be a reference to a scalar, a reference to -an array, a reference to a hash or a reference to a subroutine. + =over 8 -Note that, if your code is running under the recommended C pragma, it may be helpful to declare these package variables -via C perhaps something like this: + =item B<-help> - use vars qw/ $opt_size @opt_sizes $opt_bar /; + Print a brief help message and exits. -If a REF SCALAR is supplied, the new value is stored in the referenced -variable. If the option occurs more than once, the previous value is -overwritten. + =item B<-man> -If a REF ARRAY is supplied, the new value is appended (pushed) to the -referenced array. + Prints the manual page and exits. -If a REF HASH is supplied, the option value should look like "key" or -"key=value" (if the "=value" is omitted then a value of 1 is implied). -In this case, the element of the referenced hash with the key "key" -is assigned "value". + =back -If a REF CODE is supplied, the referenced subroutine is called with -two arguments: the option name and the option value. -The option name is always the true name, not an abbreviation or alias. + =head1 DESCRIPTION -=head2 Aliases and abbreviations + B will read the given input file(s) and do someting + useful with the contents thereof. -The option name may actually be a list of option names, separated by -"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name -of this option. If no linkage is specified, options "foo", "bar" and -"blech" all will set $opt_foo. For convenience, the single character -"?" is allowed as an alias, e.g. "help|?". + =cut -Option names may be abbreviated to uniqueness, depending on -configuration option B. +See L for details. -=head2 Non-option call-back routine +=head2 Storing options in a hash -A special option specifier, EE, can be used to designate a subroutine -to handle non-option arguments. GetOptions will immediately call this -subroutine for every non-option it encounters in the options list. -This subroutine gets the name of the non-option passed. -This feature requires configuration option B, see section -CONFIGURATION OPTIONS. +Sometimes, for example when there are a lot of options, having a +separate variable for each of them can be cumbersome. GetOptions() +supports, as an alternative mechanism, storing options in a hash. -See also the examples. +To obtain this, a reference to a hash must be passed I to GetOptions(). For each option that is specified on the +command line, the option value will be stored in the hash with the +option name as key. Options that are not actually used on the command +line will not be put in the hash, on other words, +C (or defined()) can be used to test if an option +was used. The drawback is that warnings will be issued if the program +runs under C and uses C<$h{option}> without testing with +exists() or defined() first. -=head2 Option starters + my %h = (); + GetOptions (\%h, 'length=i'); # will store in $h{length} -On the command line, options can start with B<-> (traditional), B<--> -(POSIX) and B<+> (GNU, now being phased out). The latter is not -allowed if the environment variable B has been -defined. +For options that take list or hash values, it is necessary to indicate +this by appending an C<@> or C<%> sign after the type: -Options that start with "--" may have an argument appended, separated -with an "=", e.g. "--foo=bar". + GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} -=head2 Return values and Errors +To make things more complicated, the hash may contain references to +the actual destinations, for example: -Configuration errors and errors in the option definitions are -signalled using C and will terminate the calling -program unless the call to C was embedded -in C or C was trapped using C<$SIG{__DIE__}>. + my $len = 0; + my %h = ('length' => \$len); + GetOptions (\%h, 'length=i'); # will store in $len -A return value of 1 (true) indicates success. +This example is fully equivalent with: -A return status of 0 (false) indicates that the function detected one -or more errors during option parsing. These errors are signalled using -C and can be trapped with C<$SIG{__WARN__}>. + my $len = 0; + GetOptions ('length=i' => \$len); # will store in $len -Errors that can't happen are signalled using C. +Any mixture is possible. For example, the most frequently used options +could be stored in variables while all other options get stored in the +hash: -=head1 COMPATIBILITY + my $verbose = 0; # frequently referred + my $debug = 0; # frequently referred + my %h = ('verbose' => \$verbose, 'debug' => \$debug); + GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); + if ( $verbose ) { ... } + if ( exists $h{filter} ) { ... option 'filter' was specified ... } -Getopt::Long::GetOptions() is the successor of -B that came with Perl 4. It is fully upward compatible. -In fact, the Perl 5 version of newgetopt.pl is just a wrapper around -the module. +=head2 Bundling -If an "@" sign is appended to the argument specifier, the option is -treated as an array. Value(s) are not set, but pushed into array -@opt_name. If explicit linkage is supplied, this must be a reference -to an ARRAY. +With bundling it is possible to set several single-character options +at once. For example if C, C and C are all valid options, -If an "%" sign is appended to the argument specifier, the option is -treated as a hash. Value(s) of the form "name=value" are set by -setting the element of the hash %opt_name with key "name" to "value" -(if the "=value" portion is omitted it defaults to 1). If explicit -linkage is supplied, this must be a reference to a HASH. + -vax -If configuration option B is set (see section -CONFIGURATION OPTIONS), options that start with "+" or "-" may also -include their arguments, e.g. "+foo=bar". This is for compatiblity -with older implementations of the GNU "getopt" routine. +would set all three. -If the first argument to GetOptions is a string consisting of only -non-alphanumeric characters, it is taken to specify the option starter -characters. Everything starting with one of these characters from the -starter will be considered an option. B +Getopt::Long supports two levels of bundling. To enable bundling, a +call to Getopt::Long::Configure is required. -For convenience, option specifiers may have a leading B<-> or B<-->, -so it is possible to write: +The first level of bundling can be enabled with: - GetOptions qw(-foo=s --bar=i --ar=s); + Getopt::Long::Configure ("bundling"); -=head1 EXAMPLES +Configured this way, single-character options can be bundled but long +options B always start with a double dash C<--> to avoid +abiguity. For example, when C, C, C and C are all valid +options, -If the option specifier is "one:i" (i.e. takes an optional integer -argument), then the following situations are handled: + -vax - -one -two -> $opt_one = '', -two is next option - -one -2 -> $opt_one = -2 +would set C, C and C, but -Also, assume specifiers "foo=s" and "bar:s" : + --vax - -bar -xxx -> $opt_bar = '', '-xxx' is next option - -foo -bar -> $opt_foo = '-bar' - -foo -- -> $opt_foo = '--' +would set C. -In GNU or POSIX format, option names and values can be combined: +The second level of bundling lifts this restriction. It can be enabled +with: - +foo=blech -> $opt_foo = 'blech' - --bar= -> $opt_bar = '' - --bar=-- -> $opt_bar = '--' + Getopt::Long::Configure ("bundling_override"); -Example of using variable references: +Now, C<-vax> would set the option C. - $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); +When any level of bundling is enabled, option values may be inserted +in the bundle. For example: -With command line options "-foo blech -bar 24 -ar xx -ar yy" -this will result in: + -h24w80 - $foo = 'blech' - $opt_bar = 24 - @ar = ('xx','yy') +is equivalent to -Example of using the EE option specifier: + -h 24 -w 80 - @ARGV = qw(-foo 1 bar -foo 2 blech); - GetOptions("foo=i", \$myfoo, "<>", \&mysub); +When configured for bundling, single-character options are matched +case sensitive while long options are matched case insensitive. To +have the single-character options matched case insensitive as well, +use: -Results: + Getopt::Long::Configure ("bundling", "ignorecase_always"); - mysub("bar") will be called (with $myfoo being 1) - mysub("blech") will be called (with $myfoo being 2) +It goes without saying that bundling can be quite confusing. -Compare this with: +=head2 The lonesome dash - @ARGV = qw(-foo 1 bar -foo 2 blech); - GetOptions("foo=i", \$myfoo); +Normally, a lone dash C<-> on the command line will not be considered +an option. Option processing will terminate (unless "permute" is +configured) and the dash will be left in C<@ARGV>. -This will leave the non-options in @ARGV: +It is possible to get special treatment for a lone dash. This can be +achieved by adding an option specification with an empty name, for +example: - $myfoo -> 2 - @ARGV -> qw(bar blech) + GetOptions ('' => \$stdio); -=head1 CONFIGURATION OPTIONS +A lone dash on the command line will now be a legal option, and using +it will set variable C<$stdio>. -B can be configured by calling subroutine -B. This subroutine takes a list of quoted -strings, each specifying a configuration option to be set, e.g. -B. Options can be reset by prefixing with B, e.g. -B. Case does not matter. Multiple calls to B -are possible. +=head2 Argument callback -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 B routine. Besides, it -is much easier. +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. + +For example: + + my $width = 80; + sub process { ... } + GetOptions ('width=i' => \$width, '<>' => \&process); + +When applied to the following command line: + + arg1 --width=72 arg2 --width=60 arg3 + +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>. + +This feature requires configuration option B, see section +L. + +=head1 Configuring Getopt::Long + +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 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: @@ -1202,126 +1935,178 @@ 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 B 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 enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. -=item getopt_compat +=item gnu_compat -Allow '+' to start options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B is reset. +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 non-options are allowed to be mixed with -options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case b is reset. +Whether command line arguments are allowed to be mixed with options. +Default is disabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is enabled. -See also B, which is the opposite of B. +See also C, which is the opposite of C. =item permute -Whether non-options are allowed to be mixed with -options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B is reset. -Note that B is the opposite of B. +Whether command line arguments are allowed to be mixed with options. +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 B is set, this means that +If C is enabled, this means that - -foo arg1 -bar arg2 arg3 + --foo arg1 --bar arg2 arg3 is equivalent to - -foo -bar arg1 arg2 arg3 + --foo --bar arg1 arg2 arg3 -If a non-option call-back routine is specified, @ARGV will always be -empty upon succesful return of GetOptions since all options have been -processed, except when B<--> is used: +If an argument callback routine is specified, C<@ARGV> will always be +empty upon succesful return of GetOptions() since all options have been +processed. The only exception is when C<--> is used: - -foo arg1 -bar arg2 -- arg3 + --foo arg1 --bar arg2 -- arg3 -will call the call-back routine for arg1 and arg2, and terminate -leaving arg2 in @ARGV. +This will call the callback routine for arg1 and arg2, and then +terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. -If B is set, options processing +If C is enabled, options processing terminates when the first non-option is encountered. - -foo arg1 -bar arg2 arg3 + --foo arg1 --bar arg2 arg3 is equivalent to - -foo -- arg1 -bar arg2 arg3 + --foo -- arg1 --bar arg2 arg3 -=item bundling (default: reset) +If C is also enabled, options processing will terminate +at the first unrecognized option, or non-option, whichever comes +first. -Setting this variable to a non-zero value will allow single-character -options to be bundled. To distinguish bundles from long option names, -long options must be introduced with B<--> and single-character -options (and bundles) with B<->. For example, +=item bundling (default: disabled) - ps -vax --vax +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 bundles with C<->. -would be equivalent to +Note that, if you have options C, C and C, and +auto_abbrev enabled, possible arguments and option settings are: - ps -v -a -x --vax + using argument sets option(s) + ------------------------------------------ + -a, --a a + -l, --l l + -al, -la, -ala, -all,... a, l + --al, --all all -provided "vax", "v", "a" and "x" have been defined to be valid -options. +The suprising part is that C<--a> sets option C (due to auto +completion), not C. -Bundled options can also include a value in the bundle; for strings -this value is the rest of the bundle, but integer and floating values -may be combined in the bundle, e.g. +Note: disabling C also disables C. - scale -h24w80 +=item bundling_override (default: disabled) -is equivalent to +If C is enabled, bundling is enabled as with +C but now long option names override option bundles. - scale -h 24 -w 80 +Note: disabling C also disables C. -Note: resetting B also resets B. +B Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. -=item bundling_override (default: reset) +=item ignore_case (default: enabled) -If B is set, bundling is enabled as with -B but now long option names override option bundles. In the -above example, B<-vax> would be interpreted as the option "vax", not -the bundle "v", "a", "x". +If enabled, case is ignored when matching long option names. If, +however, bundling is enabled as well, single character options will be +treated case-sensitive. -Note: resetting B also resets B. +With C, option specifications for options that only +differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as +duplicates. -B Using option bundling can easily lead to unexpected results, -especially when mixing long options and bundles. Caveat emptor. +Note: disabling C also disables C. -=item ignore_case (default: set) +=item ignore_case_always (default: disabled) -If set, case is ignored when matching options. +When bundling is in effect, case is ignored on single-character +options also. -Note: resetting B also resets B. +Note: disabling C also disables C. -=item ignore_case_always (default: reset) +=item auto_version (default:disabled) -When bundling is in effect, case is ignored on single-character -options also. +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. + +C will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C statement. + +=item auto_help (default:disabled) -Note: resetting B also resets B. +Automatically provide support for the B<--help> and B<-?> options if +the application did not specify a handler for this option itself. -=item pass_through (default: reset) +Getopt::Long will provide a help message using module L. The +message, derived from the SYNOPSIS POD section, will be written to +standard output and processing will terminate. -Unknown options are passed through in @ARGV instead of being flagged -as errors. This makes it possible to write wrapper scripts that -process only part of the user supplied options, and passes the +C will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C statement. + +=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 +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 B is also set. +If C is enabled, options processing will terminate at +the first unrecognized option, or non-option, whichever comes first. +However, if C 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. See also B. +The string that starts options. If a constant string is not +sufficient, see C. =item prefix_pattern @@ -1329,45 +2114,222 @@ 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 -=head1 OTHER USEFUL VARIABLES +=head1 Exportable Methods -=over 12 +=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 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 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.: -=item $Getopt::Long::VERSION + GetOptions("version" => \&VersionMessage); -The version number of this Getopt::Long implementation in the format -C.C. This can be used to have Exporter check the -version, e.g. +Use this instead: - use Getopt::Long 3.00; + GetOptions("version" => sub { VersionMessage() }); -You can inspect $Getopt::Long::major_version and -$Getopt::Long::minor_version for the individual components. +=item HelpMessage -=item $Getopt::Long::error +This subroutine produces a standard help message, derived from the +program's POD section SYNOPSIS using L. It takes the same +arguments as VersionMessage(). In particular, you cannot tie it +directly to an option, e.g.: -Internal error flag. May be incremented from a call-back routine to -cause options parsing to fail. + 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 +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__}>. + +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__}>. + +=head1 Legacy + +The earliest development of C started in 1990, with Perl +version 4. As a result, its development, and the development of +Getopt::Long, has gone through several stages. Since backward +compatibility has always been extremely important, the current version +of Getopt::Long still supports a lot of constructs that nowadays are +no longer necessary or otherwise unwanted. This section describes +briefly some of these 'features'. + +=head2 Default destinations + +When no destination is specified for an option, GetOptions will store +the resultant value in a global variable named CI, where +I is the primary name of this option. When a progam executes +under C (recommended), these variables must be +pre-declared with our() or C. + + our $opt_length = 0; + GetOptions ('length=i'); # will store in $opt_length + +To yield a usable Perl variable, characters that are not part of the +syntax for variables are translated to underscores. For example, +C<--fpp-struct-return> will set the variable +C<$opt_fpp_struct_return>. Note that this variable resides in the +namespace of the calling program, not necessarily C
. For +example: + + GetOptions ("size=i", "sizes=i@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +=head2 Alternative option starters + +A string of alternative option starter characters may be passed as the +first argument (or the first argument after a leading hash reference +argument). + + my $len = 0; + GetOptions ('/', 'length=i' => $len); + +Now the command line may look like: + + /length 24 -- arg + +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 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 C routine that was introduced +in version 2.17. Besides, it is much easier. + +=head1 Trouble Shooting + +=head2 GetOptions does not return a false result when an option is not supplied + +That's why they're called 'options'. + +=head2 GetOptions does not split the command line correctly + +The command line is not split by GetOptions, but by the command line +interpreter (CLI). On Unix, this is the shell. On Windows, it is +COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. + +It is important to know that these CLIs may behave different when the +command line contains special characters, in particular quotes or +backslashes. For example, with Unix shells you can use single quotes +(C<'>) and double quotes (C<">) to group words together. The following +alternatives are equivalent on Unix: + + "two words" + 'two words' + two\ words + +In case of doubt, insert the following statement in front of your Perl +program: + + print STDERR (join("|",@ARGV),"\n"); + +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 +version 2.13. + + use Getopt::Long; + GetOptions ("help|?"); # -help and -? will both set $opt_help + =head1 AUTHOR -Johan Vromans Ejvromans@squirrel.nlE +Johan Vromans =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1998 by Johan Vromans. +This program is Copyright 2003,1990 by Johan Vromans. This program is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License -as published by the Free Software Foundation; either version 2 -of the License, or (at your option) any later version. +modify it under the terms of the Perl Artistic License or the +GNU General Public License as published by the Free Software +Foundation; either version 2 of the License, or (at your option) any +later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -1375,7 +2337,8 @@ 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 +