-# GetOpt::Long.pm -- POSIX compatible options parsing
+# GetOpt::Long.pm -- Universal options parsing
-# RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 jv Exp $
+package Getopt::Long;
+
+# RCS Status : $Id: GetoptLong.pl,v 2.21 1999-08-04 10:33:07+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Fri Apr 5 21:02:52 1996
-# Update Count : 433
+# Last Modified On: Wed Aug 4 10:08:50 1999
+# Update Count : 709
# Status : Released
-package Getopt::Long;
-require 5.000;
-require Exporter;
+################ Copyright ################
+
+# This program is Copyright 1990,1999 by Johan Vromans.
+# This program is free software; you can redistribute it and/or
+# 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,
+# MA 02139, USA.
+
+################ Module Preamble ################
-@ISA = qw(Exporter);
-@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
-use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
- $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
- $VERSION $major_version $minor_version);
use strict;
+BEGIN {
+ require 5.004;
+ use Exporter ();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ $VERSION = "2.20";
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw();
+ use AutoLoader qw(AUTOLOAD);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+# Official invisible variables.
+use vars qw($genprefix);
+
+# Public subroutines.
+sub Configure (@);
+sub config (@); # deprecated name
+sub GetOptions;
+
+# Private subroutines.
+sub ConfigDefaults ();
+sub FindOption ($$$$$$$);
+sub Croak (@); # demand loading the real Croak
+
+################ Local Variables ################
+
+################ Resident subroutines ################
+
+sub ConfigDefaults () {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+# Set defaults.
+ConfigDefaults ();
+
+################ Package return ################
+
+1;
+
+__END__
+
+################ AutoLoading subroutines ################
+
+# RCS Status : $Id: GetoptLongAl.pl,v 2.22 1999-07-07 12:57:05+02 jv Exp $
+# Author : Johan Vromans
+# Created On : Fri Mar 27 11:50:30 1998
+# Last Modified By: Johan Vromans
+# Last Modified On: Wed Jul 7 12:47:57 1999
+# Update Count : 28
+# Status : Released
+
+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
+ # 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
+
+ $error = '';
+
+ print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
+ "called from package \"$pkg\".",
+ "\n ",
+ 'GetOptionsAl $Revision: 2.22 $ ',
+ "\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.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( ref($optionlist[0]) and
+ "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ # Be careful not to interpret '<>' as option starters.
+ if ( $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
+ $genprefix = shift (@optionlist);
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix =~ s/(\W)/\\$1/g;
+ $genprefix = "([" . $genprefix . "])";
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ %bopctl = ();
+ while ( @optionlist > 0 ) {
+ my $opt = shift (@optionlist);
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ 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";
+ 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 $debug;
+ unshift (@optionlist, $userlinkage->{$o});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$o\" to $optionlist[0]\n")
+ if $debug;
+ if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ }
+ 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 ( 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} !~ /\%$/;
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $o;
+ $ov =~ s/\W/_/g;
+ if ( $c =~ /@/ ) {
+ print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $c =~ /%/ ) {
+ print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
+ }
+
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+
+ # Sort the possible long option names.
+ @opctl = sort(keys (%opctl)) if $autoabbrev;
+
+ # 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");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+ while ( @ARGV > 0 ) {
+
+ #### Get next argument ####
+
+ $opt = shift (@ARGV);
+ print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+
+ #### Determine what we have ####
+
+ # 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);
+ }
+
+ 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
+
+ ($found, $opt, $arg, $dsttype, $incr, $key) =
+ FindOption ($genprefix, $argend, $opt,
+ \%opctl, \%bopctl, \@opctl, \%aliases);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ if ( defined $arg ) {
+ $opt = $aliases{$opt} if defined $aliases{$opt};
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+ if ( $incr ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
+ if $debug;
+ &{$linkage{$opt}}($opt, $arg);
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ Croak ("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $dsttype eq '@' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $dsttype eq '%' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ if ( $incr ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ }
+ }
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
+ elsif ( $order == $PERMUTE ) {
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ &$cb ($tryopt);
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
+ next;
+ }
+
+ # ...otherwise, terminate.
+ else {
+ # Push this one back and exit.
+ unshift (@ARGV, $tryopt);
+ return ($error == 0);
+ }
+
+ }
+
+ # Finish.
+ if ( $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
+ unshift (@ARGV, @ret) if @ret > 0;
+ }
+
+ return ($error == 0);
+}
+
+# Option lookup.
+sub FindOption ($$$$$$$) {
+
+ # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+ # returns (0) otherwise.
+
+ my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+ my $key; # hash key for a hash option
+ my $arg;
+
+ print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
+
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+
+ $opt = $+;
+ 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
+
+ # If it is a long option, it may include the value.
+ if (($starter eq "--" || ($getopt_compat && !$bundling))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ 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
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 and
+ defined ($rest) and
+ defined ($type = $opctl->{$tryopt.$rest}) ) {
+ print STDERR ("=> $starter$tryopt rebundled to ",
+ "$starter$tryopt$rest\n") if $debug;
+ $tryopt .= $rest;
+ undef $rest;
+ }
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev ) {
+ # Downcase if allowed.
+ $tryopt = $opt = lc ($opt) if $ignorecase;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @{$names});
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "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->{$_};
+ $hit{$_} = 1;
+ }
+ # 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);
+ }
+ @hits = keys(%hit);
+ }
+
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
+
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
+
+ # Check validity by fetching the info.
+ $type = $optbl->{$tryopt} unless defined $type;
+ unless ( defined $type ) {
+ return (0) if $passthrough;
+ warn ("Unknown option: ", $opt, "\n");
+ $error++;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' || $type eq '+' ) {
+ $arg = 1; # supply explicit value
+ $incr = $type eq '+';
+ }
+ else {
+ substr ($opt, 0, 2) = ''; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+
+ # Get mandatory status and type info.
+ my $mand;
+ ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
+
+ # 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 "=" ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ undef $opt;
+ }
+ if ( $mand eq ":" ) {
+ $arg = $type eq "s" ? '' : 0;
+ }
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (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);
+ }
+
+ #### 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 "=";
+
+ # An optional string takes almost anything.
+ return (1, $opt,$arg,$dsttype,$incr,$key)
+ if defined $optarg || defined $rest;
+ return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
+ $arg = $1;
+ $rest = $2;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^-?[0-9]+$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0;
+ }
+ }
+ }
+
+ 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 = $+;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
+ }
+ }
+ }
+ else {
+ Croak ("GetOpt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $arg, $dsttype, $incr, $key);
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( $try eq 'default' or $try eq 'defaults' ) {
+ ConfigDefaults () if $action;
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ ) {
+ $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=(.+)$/ ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ /$genprefix/; };
+ Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ Croak ("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+ require 'Carp.pm';
+ $Carp::CarpLevel = 1;
+ Carp::croak(@_);
+};
+
+################ Documentation ################
+
=head1 NAME
GetOptions - extended processing of command line options
variable that will be set when the option is used. For example, the
following call to GetOptions:
- &GetOptions("size=i" => \$offset);
+ GetOptions("size=i" => \$offset);
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.
Alternatively, the first argument to GetOptions may be a reference to
-a HASH describing the linkage for the options. The following call is
-equivalent to the example above:
+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:
%optctl = ("size" => \$offset);
- &GetOptions(\%optctl, "size=i");
+ GetOptions(\%optctl, "size=i");
Linkage may be specified using either of the above methods, or both.
Linkage specified in the argument list takes precedence over the
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. Values for argument specifiers are:
+followed by an argument specifier.
-=over 8
+Options that do not take arguments will have no argument specifier.
+The option variable will be set to 1 if the option is used.
-=item <none>
+For the other options, the values for argument specifiers are:
-Option does not take an argument.
-The option variable will be set to 1.
+=over 8
=item !
(with value 0).
The option variable will be set to 1, or 0 if negated.
+=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 B<+> specifier is ignored if the option destination is not a SCALAR.
+
=item =s
Option takes a mandatory string argument.
the HASH. For example:
%optctl = ();
- &GetOptions (\%optctl, "size=i");
+ GetOptions (\%optctl, "size=i");
will perform the equivalent of the assignment
For array options, a reference to an array is used, e.g.:
%optctl = ();
- &GetOptions (\%optctl, "sizes=i@");
+ GetOptions (\%optctl, "sizes=i@");
with command line "-sizes 24 -sizes 48" will perform the equivalent of
the assignment
$optctl{"sizes"} = [24, 48];
+For hash options (an option whose argument looks like "name=value"),
+a reference to a hash is used, e.g.:
+
+ %optctl = ();
+ GetOptions (\%optctl, "define=s%");
+
+with command line "--define foo=hello --define bar=world" will perform the
+equivalent of the assignment
+
+ $optctl{"define"} = {foo=>'hello', bar=>'world')
+
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,
in the namespace of the calling program, not necessarily B<main>.
For example:
- &GetOptions ("size=i", "sizes=i@");
+ GetOptions ("size=i", "sizes=i@");
with command line "-size 10 -sizes 24 -sizes 48" will perform the
equivalent of the assignments
identifier is $opt_ .
The linkage specifier can be a reference to a scalar, a reference to
-an array or a reference to a subroutine.
+an array, a reference to a hash or a reference to a subroutine.
+
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, it may be helpful to declare these package variables
+via C<use vars> perhaps something like this:
+
+ use vars qw/ $opt_size @opt_sizes $opt_bar /;
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
If a REF ARRAY is supplied, the new value is appended (pushed) to the
referenced array.
+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".
+
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.
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
-op this option. If no linkage is specified, options "foo", "bar" and
-"blech" all will set $opt_foo.
+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|?".
Option names may be abbreviated to uniqueness, depending on
-configuration variable $Getopt::Long::autoabbrev.
+configuration option B<auto_abbrev>.
=head2 Non-option call-back routine
-A special option specifier, <>, can be used to designate a subroutine
+A special option specifier, E<lt>E<gt>, 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 $Getopt::Long::order to have the value $PERMUTE.
+This feature requires configuration option B<permute>, see section
+CONFIGURATION OPTIONS.
+
See also the examples.
=head2 Option starters
Options that start with "--" may have an argument appended, separated
with an "=", e.g. "--foo=bar".
-=head2 Return value
+=head2 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using C<die()> and will terminate the calling
+program unless the call to C<Getopt::Long::GetOptions()> was embedded
+in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
-A return status of 0 (false) indicates that the function detected
-one or more errors.
+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
+C<warn()> and can be trapped with C<$SIG{__WARN__}>.
+
+Errors that can't happen are signalled using C<Carp::croak()>.
=head1 COMPATIBILITY
the module.
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. This only applies if no linkage is supplied.
-
-If configuration variable $Getopt::Long::getopt_compat is set to a
-non-zero value, options that start with "+" may also include their
-arguments, e.g. "+foo=bar". This is for compatiblity with older
-implementations of the GNU "getopt" routine.
-
-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<Using a starter argument is
-strongly deprecated.>
+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.
+
+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.
+
+If configuration option B<getopt_compat> 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.
+
+If the first argument to GetOptions (after the optional linkage
+specification) 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. GetOptions will not interpret a leading
+"<>" as option starters if the next argument is a reference. To
+force "<" and ">" as option starters, use "><". Confusing? Well,
+B<using a starter argument is strongly deprecated.>
For convenience, option specifiers may have a leading B<-> or B<-->,
so it is possible to write:
--bar= -> $opt_bar = ''
--bar=-- -> $opt_bar = '--'
-Example of using variabel references:
+Example of using variable references:
- $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
+ $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
With command line options "-foo blech -bar 24 -ar xx -ar yy"
this will result in:
- $bar = 'blech'
+ $foo = 'blech'
$opt_bar = 24
@ar = ('xx','yy')
-Example of using the <> option specifier:
+Example of using the E<lt>E<gt> option specifier:
@ARGV = qw(-foo 1 bar -foo 2 blech);
- &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
+ GetOptions("foo=i", \$myfoo, "<>", \&mysub);
Results:
- &mysub("bar") will be called (with $myfoo being 1)
- &mysub("blech") will be called (with $myfoo being 2)
+ mysub("bar") will be called (with $myfoo being 1)
+ mysub("blech") will be called (with $myfoo being 2)
Compare this with:
@ARGV = qw(-foo 1 bar -foo 2 blech);
- &GetOptions("foo=i", \$myfoo);
+ GetOptions("foo=i", \$myfoo);
This will leave the non-options in @ARGV:
$myfoo -> 2
@ARGV -> qw(bar blech)
-=head1 CONFIGURATION VARIABLES
+=head1 CONFIGURATION OPTIONS
-The following variables can be set to change the default behaviour of
-GetOptions():
+B<GetOptions> can be configured by calling subroutine
+B<Getopt::Long::Configure>. This subroutine takes a list of quoted
+strings, each specifying a configuration option to be set, e.g.
+B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
+B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
+are possible.
+
+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<config> routine. Besides, it
+is much easier.
+
+The following options are available:
=over 12
-=item $Getopt::Long::autoabbrev
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item auto_abbrev
Allow option names to be abbreviated to uniqueness.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
-=item $Getopt::Long::getopt_compat
+=item getopt_compat
Allow '+' to start options.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
-=item $Getopt::Long::order
+=item require_order
Whether non-options are allowed to be mixed with
options.
-Default is $REQUIRE_ORDER if environment variable
-POSIXLY_CORRECT has been set, $PERMUTE otherwise.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
-$PERMUTE means that
+See also B<permute>, which is the opposite of B<require_order>.
+
+=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<permute> is reset.
+Note that B<permute> is the opposite of B<require_order>.
+
+If B<permute> is set, this means that
-foo arg1 -bar arg2 arg3
will call the call-back routine for arg1 and arg2, and terminate
leaving arg2 in @ARGV.
-If $Getopt::Long::order is $REQUIRE_ORDER, options processing
-terminates when the first non-option is encountered.
-
- -foo arg1 -bar arg2 arg3
-
-is equivalent to
-
- -foo -- arg1 -bar arg2 arg3
-
-$RETURN_IN_ORDER is not supported by GetOptions().
-
-=item $Getopt::Long::bundling
-
-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,
-
- ps -vax --vax
-
-would be equivalent to
-
- ps -v -a -x --vax
-
-provided "vax", "v", "a" and "x" have been defined to be valid
-options.
-
-Bundled options can also include a value in the bundle; this value has
-to be the last part of the bundle, e.g.
-
- scale -h24 -w80
-
-is equivalent to
-
- scale -h 24 -w 80
-
-B<Note:> Using option bundling can easily lead to unexpected results,
-especially when mixing long options and bundles. Caveat emptor.
-
-=item $Getopt::Long::ignorecase
-
-Ignore case when matching options. Default is 1. When bundling is in
-effect, case is ignored on single-character options only if
-$Getopt::Long::ignorecase is greater than 1.
-
-=item $Getopt::Long::VERSION
-
-The version number of this Getopt::Long implementation in the format
-C<major>.C<minor>. This can be used to have Exporter check the
-version, e.g.
-
- use Getopt::Long 2.00;
-
-You can inspect $Getopt::Long::major_version and
-$Getopt::Long::minor_version for the individual components.
-
-=item $Getopt::Long::error
-
-Internal error flag. May be incremented from a call-back routine to
-cause options parsing to fail.
-
-=item $Getopt::Long::debug
-
-Enable copious debugging output. Default is 0.
-
-=back
-
-=cut
-
-################ Introduction ################
-#
-# This program is Copyright 1990,1996 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.
-#
-# 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,
-# MA 02139, USA.
-
-################ Configuration Section ################
-
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
-
-my $gen_prefix; # generic prefix (option starters)
-
-# Handle POSIX compliancy.
-if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "--|-";
- $autoabbrev = 0; # no automatic abbrev of options
- $bundling = 0; # no bundling of single letter switches
- $getopt_compat = 0; # disallow '+' to start options
- $order = $REQUIRE_ORDER;
-}
-else {
- $gen_prefix = "--|-|\\+";
- $autoabbrev = 1; # automatic abbrev of options
- $bundling = 0; # bundling off by default
- $getopt_compat = 1; # allow '+' to start options
- $order = $PERMUTE;
-}
-
-# Other configurable settings.
-$debug = 0; # for debugging
-$error = 0; # error tally
-$ignorecase = 1; # ignore case when matching options
-($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
-
-################ Subroutines ################
-
-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
- # Needed if linkage is omitted.
- my %aliases; # alias table
- my @ret = (); # accum for non-options
- my %linkage; # linkage
- my $userlinkage; # user supplied HASH
- my $genprefix = $gen_prefix; # so we can call the same module more
- # than once in differing environments
- $error = 0;
-
- print STDERR ('GetOptions $Revision: 2.3 $ ',
- "[GetOpt::Long $Getopt::Long::VERSION] -- ",
- "called from package \"$pkg\".\n",
- " autoabbrev=$autoabbrev".
- ",bundling=$bundling",
- ",getopt_compat=$getopt_compat",
- ",genprefix=\"$genprefix\"",
- ",order=$order",
- ",ignorecase=$ignorecase",
- ".\n")
- if $debug;
-
- # Check for ref HASH as first argument.
- $userlinkage = undef;
- if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) {
- $userlinkage = shift (@optionlist);
- }
+If B<require_order> is set, options processing
+terminates when the first non-option is encountered.
- # See if the first element of the optionlist contains option
- # starter characters.
- if ( $optionlist[0] =~ /^\W+$/ ) {
- $genprefix = shift (@optionlist);
- # Turn into regexp.
- $genprefix =~ s/(\W)/\\$1/g;
- $genprefix = "[" . $genprefix . "]";
- }
+ -foo arg1 -bar arg2 arg3
- # Verify correctness of optionlist.
- %opctl = ();
- %bopctl = ();
- while ( @optionlist > 0 ) {
- my $opt = shift (@optionlist);
+is equivalent to
- # Strip leading prefix so people can specify "-foo=i" if they like.
- $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
+ -foo -- arg1 -bar arg2 arg3
- if ( $opt eq '<>' ) {
- if ( (defined $userlinkage)
- && !(@optionlist > 0 && ref($optionlist[0]))
- && (exists $userlinkage->{$opt})
- && ref($userlinkage->{$opt}) ) {
- unshift (@optionlist, $userlinkage->{$opt});
- }
- unless ( @optionlist > 0
- && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
- warn ("Option spec <> requires a reference to a subroutine\n");
- $error++;
- next;
- }
- $linkage{'<>'} = shift (@optionlist);
- next;
- }
+=item bundling (default: reset)
- if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
- warn ("Error in option spec: \"", $opt, "\"\n");
- $error++;
- next;
- }
- my ($o, $c, $a) = ($1, $2);
- $c = '' unless defined $c;
+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,
- if ( ! defined $o ) {
- # empty -> '-' option
- $opctl{$o = ''} = $c;
- }
- else {
- # Handle alias names
- my @o = split (/\|/, $o);
- $o = $o[0];
- $o = lc ($o)
- if $ignorecase > 1
- || ($ignorecase
- && ($bundling ? length($o) > 1 : 1));
+ ps -vax --vax
- foreach ( @o ) {
- if ( $bundling && length($_) == 1 ) {
- $_ = lc ($_) if $ignorecase > 1;
- if ( $c eq '!' ) {
- $opctl{"no$_"} = $c;
- warn ("Ignoring '!' modifier for short option $_\n");
- $c = '';
- }
- $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 = $_;
- }
- }
- }
+would be equivalent to
- # 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 $debug;
- unshift (@optionlist, $userlinkage->{$o});
- }
- else {
- # Do nothing. Being undefined will be handled later.
- next;
- }
- }
- }
+ ps -v -a -x --vax
- # Copy the linkage. If omitted, link to global variable.
- if ( @optionlist > 0 && ref($optionlist[0]) ) {
- print STDERR ("=> link \"$o\" to $optionlist[0]\n")
- if $debug;
- if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
- $linkage{$o} = shift (@optionlist);
- }
- else {
- warn ("Invalid option linkage for \"", $opt, "\"\n");
- $error++;
- }
- }
- else {
- # Link to global $opt_XXX variable.
- # Make sure a valid perl identifier results.
- my $ov = $o;
- $ov =~ s/\W/_/g;
- if ( defined($c) && $c =~ /@/ ) {
- print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
- }
- else {
- print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
- }
- }
- }
+provided "vax", "v", "a" and "x" have been defined to be valid
+options.
- # Bail out if errors found.
- return 0 if $error;
+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.
- # Sort the possible long option names.
- my @opctl = sort(keys (%opctl)) if $autoabbrev;
+ scale -h24w80
- # 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");
- $arrow = " ";
- }
- }
+is equivalent to
- my $opt; # current option
- my $arg; # current option value, if any
- my $array; # current option is array typed
+ scale -h 24 -w 80
- # Process argument list
- while ( @ARGV > 0 ) {
+Note: resetting B<bundling> also resets B<bundling_override>.
- # >>> See also the continue block <<<
+=item bundling_override (default: reset)
- #### Get next argument ####
+If B<bundling_override> is set, bundling is enabled as with
+B<bundling> 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".
- my $starter; # option starter string, e.g. '-' or '--'
- my $rest = undef; # remainder from unbundling
- my $optarg = undef; # value supplied with --opt=value
+Note: resetting B<bundling_override> also resets B<bundling>.
- $opt = shift (@ARGV);
- $arg = undef;
- $array = 0;
- print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
- #### Determine what we have ####
+=item ignore_case (default: set)
- # 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);
- }
+If set, case is ignored when matching options.
- if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) {
- # Looks like an option.
- $opt = $2; # option name (w/o prefix)
- $starter = $1; # option starter
+Note: resetting B<ignore_case> also resets B<ignore_case_always>.
- # If it is a long option, it may include the value.
- if (($starter eq "--"
- || ($getopt_compat && $starter eq "+"))
- && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) {
- $opt = $1;
- $optarg = $2;
- print STDERR ("=> option \"", $opt,
- "\", optarg = \"$optarg\"\n") if $debug;
- }
+=item ignore_case_always (default: reset)
- }
+When bundling is in effect, case is ignored on single-character
+options also.
- # Not an option. Save it if we $PERMUTE and don't have a <>.
- elsif ( $order == $PERMUTE ) {
- # Try non-options call-back.
- my $cb;
- if ( (defined ($cb = $linkage{'<>'})) ) {
- &$cb($opt);
- }
- else {
- print STDERR ("=> saving \"$opt\" ",
- "(not an option, may permute)\n") if $debug;
- push (@ret, $opt);
- }
- next;
- }
+Note: resetting B<ignore_case_always> also resets B<ignore_case>.
- # ...otherwise, terminate.
- else {
- # Push this one back and exit.
- unshift (@ARGV, $opt);
- return ($error == 0);
- }
+=item pass_through (default: reset)
- #### Look it up ###
+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
+remaining options to some other program.
- my $tryopt = $opt; # option to try
- my $optbl = \%opctl; # table to look it up (long names)
+This can be very confusing, especially when B<permute> is also set.
- 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
- }
-
- # Try auto-abbreviation.
- elsif ( $autoabbrev ) {
- # Downcase if allowed.
- $tryopt = $opt = lc ($opt) if $ignorecase;
- # Turn option name into pattern.
- my $pat = quotemeta ($opt);
- # Look up in option names.
- my @hits = grep (/^$pat/, @opctl);
- print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
- "out of ", scalar(@opctl), "\n") if $debug;
-
- # Check for ambiguous results.
- unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
- print STDERR ("Option ", $opt, " is ambiguous (",
- join(", ", @hits), ")\n");
- $error++;
- next;
- }
+=item prefix
- # Complete the option name, if appropriate.
- if ( @hits == 1 && $hits[0] ne $opt ) {
- $tryopt = $hits[0];
- print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
- if $debug;
- }
- }
+The string that starts options. See also B<prefix_pattern>.
- # Check validity by fetching the info.
- my $type = $optbl->{$tryopt};
- unless ( defined $type ) {
- warn ("Unknown option: ", $opt, "\n");
- $error++;
- next;
- }
- # Apparently valid.
- $opt = $tryopt;
- print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+=item prefix_pattern
- #### Determine argument status ####
+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<(--|-)>.
- # If it is an option w/o argument, we're almost finished with it.
- if ( $type eq '' || $type eq '!' ) {
- if ( defined $optarg ) {
- print STDERR ("Option ", $opt, " does not take an argument\n");
- $error++;
- }
- elsif ( $type eq '' ) {
- $arg = 1; # supply explicit value
- }
- else {
- substr ($opt, 0, 2) = ''; # strip NO prefix
- $arg = 0; # supply explicit value
- }
- # When unbundling, unshift the rest with the starter.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- next;
- }
+=item debug (default: reset)
- # Get mandatory status and type info.
- my $mand;
- ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
+Enable copious debugging output.
- # 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 "=" ) {
- print STDERR ("Option ", $opt, " requires an argument\n");
- $error++;
- }
- if ( $mand eq ":" ) {
- $arg = $type eq "s" ? '' : 0;
- }
- next;
- }
+=back
- # Get (possibly optional) argument.
- $arg = (defined $rest ? $rest
- : (defined $optarg ? $optarg : shift (@ARGV)));
+=head1 OTHER USEFUL VARIABLES
- #### Check if the argument is valid for this option ####
+=over 12
- if ( $type eq "s" ) { # string
- # A mandatory string takes anything.
- next if $mand eq "=";
+=item $Getopt::Long::VERSION
- # An optional string takes almost anything.
- next if defined $optarg || defined $rest;
- next if $arg eq "-"; # ??
+The version number of this Getopt::Long implementation in the format
+C<major>.C<minor>. This can be used to have Exporter check the
+version, e.g.
- # Check for option or option list terminator.
- if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply empty value.
- $arg = '';
- }
- next;
- }
+ use Getopt::Long 3.00;
- if ( $type eq "n" || $type eq "i" ) { # numeric/integer
- if ( $arg !~ /^-?[0-9]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (number expected)\n");
- $error++;
- undef $arg; # don't assign it
- # Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- }
- else {
- # Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
- # Supply default value.
- $arg = 0;
- }
- }
- next;
- }
+You can inspect $Getopt::Long::major_version and
+$Getopt::Long::minor_version for the individual components.
- if ( $type eq "f" ) { # fixed real number, int is also ok
- if ( $arg !~ /^-?[0-9.]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (real number expected)\n");
- $error++;
- undef $arg; # don't assign it
- # Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- }
- else {
- # Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
- # Supply default value.
- $arg = 0.0;
- }
- }
- next;
- }
+=item $Getopt::Long::error
- die ("GetOpt::Long internal error (Can't happen)\n");
- }
+Internal error flag. May be incremented from a call-back routine to
+cause options parsing to fail.
- continue {
- if ( defined $arg ) {
- $opt = $aliases{$opt} if defined $aliases{$opt};
+=back
- if ( defined $linkage{$opt} ) {
- print STDERR ("=> ref(\$L{$opt}) -> ",
- ref($linkage{$opt}), "\n") if $debug;
+=head1 AUTHOR
- if ( ref($linkage{$opt}) eq 'SCALAR' ) {
- print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
- ${$linkage{$opt}} = $arg;
- }
- elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
- print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
- if $debug;
- push (@{$linkage{$opt}}, $arg);
- }
- elsif ( ref($linkage{$opt}) eq 'CODE' ) {
- print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
- if $debug;
- &{$linkage{$opt}}($opt, $arg);
- }
- else {
- print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
- "\" in linkage\n");
- die ("Getopt::Long -- internal error!\n");
- }
- }
- # No entry in linkage means entry in userlinkage.
- elsif ( $array ) {
- if ( defined $userlinkage->{$opt} ) {
- print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
- if $debug;
- push (@{$userlinkage->{$opt}}, $arg);
- }
- else {
- print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
- if $debug;
- $userlinkage->{$opt} = [$arg];
- }
- }
- else {
- print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
- $userlinkage->{$opt} = $arg;
- }
- }
- }
+Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
- # Finish.
- if ( $order == $PERMUTE ) {
- # Push back accumulated arguments
- print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
- if $debug && @ret > 0;
- unshift (@ARGV, @ret) if @ret > 0;
- }
+=head1 COPYRIGHT AND DISCLAIMER
- return ($error == 0);
-}
+This program is Copyright 1990,1999 by Johan Vromans.
+This program is free software; you can redistribute it and/or
+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.
-################ Package return ################
+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.
-1;
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut