From f56e05005c751822074f0a22aa9a98d2eb189924 Mon Sep 17 00:00:00 2001
From: markm <markm@FreeBSD.org>
Date: Thu, 16 May 2002 10:09:28 +0000
Subject: Perl is no longer in base. Long live the port!
---
contrib/perl5/lib/Getopt/Long.pm | 1890 --------------------------------------
contrib/perl5/lib/Getopt/Std.pm | 176 ----
2 files changed, 2066 deletions(-)
delete mode 100644 contrib/perl5/lib/Getopt/Long.pm
delete mode 100644 contrib/perl5/lib/Getopt/Std.pm
(limited to 'contrib/perl5/lib/Getopt')
diff --git a/contrib/perl5/lib/Getopt/Long.pm b/contrib/perl5/lib/Getopt/Long.pm
deleted file mode 100644
index 472527d..0000000
--- a/contrib/perl5/lib/Getopt/Long.pm
+++ /dev/null
@@ -1,1890 +0,0 @@
-# GetOpt::Long.pm -- Universal options parsing
-
-package Getopt::Long;
-
-# RCS Status : $Id: GetoptLong.pl,v 2.26 2001-01-31 10:20:29+01 jv Exp $
-# Author : Johan Vromans
-# Created On : Tue Sep 11 15:00:12 1990
-# Last Modified By: Johan Vromans
-# Last Modified On: Sat Jan 6 17:12:27 2001
-# Update Count : 748
-# Status : Released
-
-################ Copyright ################
-
-# This program is Copyright 1990,2001 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 ################
-
-use 5.004;
-
-use strict;
-
-use vars qw($VERSION $VERSION_STRING);
-$VERSION = 2.25;
-$VERSION_STRING = "2.25";
-
-use Exporter;
-use AutoLoader qw(AUTOLOAD);
-
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-@ISA = qw(Exporter);
-%EXPORT_TAGS = qw();
-BEGIN {
- # Init immediately so their contents can be used in the 'use vars' below.
- @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
- @EXPORT_OK = qw();
-}
-
-# 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 $caller $gnu_compat);
-
-# 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
- $gnu_compat = 0; # require --opt=val if value is optional
-}
-
-# Override import.
-sub import {
- my $pkg = shift; # package
- my @syms = (); # symbols to import
- my @config = (); # configuration
- my $dest = \@syms; # symbols first
- for ( @_ ) {
- if ( $_ eq ':config' ) {
- $dest = \@config; # config next
- next;
- }
- push (@$dest, $_); # push
- }
- # Hide one level and call super.
- local $Exporter::ExportLevel = 1;
- $pkg->SUPER::import(@syms);
- # And configure.
- Configure (@config) if @config;
-}
-
-################ Initialization ################
-
-# 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+)/;
-
-ConfigDefaults();
-
-################ OO Interface ################
-
-package Getopt::Long::Parser;
-
-# NOTE: The object oriented routines use $error for thread locking.
-my $_lock = sub {
- lock ($Getopt::Long::error) if $] >= 5.005
-};
-
-# Store a copy of the default configuration. Since ConfigDefaults has
-# just been called, what we get from Configure is the default.
-my $default_config = do {
- &$_lock;
- Getopt::Long::Configure ()
-};
-
-sub new {
- my $that = shift;
- my $class = ref($that) || $that;
- my %atts = @_;
-
- # Register the callers package.
- my $self = { caller_pkg => (caller)[0] };
-
- bless ($self, $class);
-
- # Process config attributes.
- if ( defined $atts{config} ) {
- &$_lock;
- my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
- $self->{settings} = Getopt::Long::Configure ($save);
- delete ($atts{config});
- }
- # Else use default config.
- else {
- $self->{settings} = $default_config;
- }
-
- if ( %atts ) { # Oops
- Getopt::Long::Croak(__PACKAGE__.": unhandled attributes: ".
- join(" ", sort(keys(%atts))));
- }
-
- $self;
-}
-
-sub configure {
- my ($self) = shift;
-
- &$_lock;
-
- # Restore settings, merge new settings in.
- my $save = Getopt::Long::Configure ($self->{settings}, @_);
-
- # Restore orig config and save the new config.
- $self->{settings} = Configure ($save);
-}
-
-sub getoptions {
- my ($self) = shift;
-
- &$_lock;
-
- # Restore config settings.
- my $save = Getopt::Long::Configure ($self->{settings});
-
- # Call main routine.
- my $ret = 0;
- $Getopt::Long::caller = $self->{caller_pkg};
- eval { $ret = Getopt::Long::GetOptions (@_); };
-
- # Restore saved settings.
- Getopt::Long::Configure ($save);
-
- # Handle errors and return value.
- die ($@) if $@;
- return $ret;
-}
-
-package Getopt::Long;
-
-################ Package return ################
-
-1;
-
-__END__
-
-################ AutoLoading subroutines ################
-
-# RCS Status : $Id: GetoptLongAl.pl,v 2.30 2001-01-31 10:21:11+01 jv Exp $
-# Author : Johan Vromans
-# Created On : Fri Mar 27 11:50:30 1998
-# Last Modified By: Johan Vromans
-# Last Modified On: Tue Dec 26 18:01:16 2000
-# Update Count : 98
-# 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 || (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.30 $ ',
- "\n ",
- "ARGV: (@ARGV)",
- "\n ",
- "autoabbrev=$autoabbrev,".
- "bundling=$bundling,",
- "getopt_compat=$getopt_compat,",
- "gnu_compat=$gnu_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 only.
- 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;
-
- # $linko keeps track of the primary name the user specified.
- # This name will be used for the internal or external linkage.
- # In other words, if the user specifies "FoO|BaR", it will
- # match any case combinations of 'foo' and 'bar', but if a global
- # variable needs to be set, it will be $opt_FoO in the exact case
- # as specified.
- my $linko;
-
- if ( ! defined $o ) {
- # empty -> '-' option
- $linko = $o = '';
- $opctl{''} = $c;
- $bopctl{''} = $c if $bundling;
- }
- else {
- # Handle alias names
- my @o = split (/\|/, $o);
- $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");
- $opctl{$_} = $bopctl{$_} = '';
- }
- else {
- $opctl{$_} = $bopctl{$_} = $c;
- }
- }
- else {
- $_ = lc ($_) if $ignorecase;
- if ( $c eq '!' ) {
- $opctl{"no$_"} = $c;
- $opctl{$_} = ''
- }
- else {
- $opctl{$_} = $c;
- }
- }
- if ( defined $a ) {
- # Note alias.
- $aliases{$_} = $a;
- }
- else {
- # Set primary name.
- $a = $_;
- }
- }
- }
-
- # 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->{$linko} &&
- ref($userlinkage->{$linko}) ) {
- print STDERR ("=> found userlinkage for \"$linko\": ",
- "$userlinkage->{$linko}\n")
- if $debug;
- unshift (@optionlist, $userlinkage->{$linko});
- }
- 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 \"$linko\" to $optionlist[0]\n")
- if $debug;
- if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
- $linkage{$linko} = shift (@optionlist);
- }
- elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
- $linkage{$linko} = 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{$linko} = 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 = $linko;
- $ov =~ s/\W/_/g;
- if ( $c =~ /@/ ) {
- print STDERR ("=> link \"$linko\" to \@$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$linko} = \\\@".$pkg."::opt_$ov;");
- }
- elsif ( $c =~ /%/ ) {
- print STDERR ("=> link \"$linko\" to \%$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$linko} = \\\%".$pkg."::opt_$ov;");
- }
- else {
- print STDERR ("=> link \"$linko\" to \$$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$linko} = \\\$".$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
- my $goon = 1;
- while ( $goon && @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 ) {
- if ( defined $aliases{$opt} ) {
- print STDERR ("=> alias \"$opt\" -> \"$aliases{$opt}\"\n")
- if $debug;
- $opt = $aliases{$opt};
- }
-
- if ( defined $linkage{$opt} ) {
- print STDERR ("=> ref(\$L{$opt}) -> ",
- 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;
- local ($@);
- eval {
- &{$linkage{$opt}}($opt, $arg);
- };
- print STDERR ("=> die($@)\n") if $debug && $@ ne '';
- if ( $@ =~ /^!/ ) {
- if ( $@ =~ /^!FINISH\b/ ) {
- $goon = 0;
- }
- }
- elsif ( $@ ne '' ) {
- warn ($@);
- $error++;
- }
- }
- 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{'<>'})) ) {
- local ($@);
- eval {
- &$cb ($tryopt);
- };
- print STDERR ("=> die($@)\n") if $debug && $@ ne '';
- if ( $@ =~ /^!/ ) {
- if ( $@ =~ /^!FINISH\b/ ) {
- $goon = 0;
- }
- }
- elsif ( $@ ne '' ) {
- warn ($@);
- $error++;
- }
- }
- 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;
- return 0 if $opt eq "-" && !defined $opctl->{""};
-
- $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 = 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;
- $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 ( $gnu_compat ) {
- return (1, $opt, $optarg, $dsttype, $incr, $key)
- if defined $optarg;
- return (1, $opt, $type eq "s" ? '' : 0, $dsttype, $incr, $key)
- if $mand eq ':';
- }
-
- # Check if there is an option argument available.
- if ( defined $optarg
- ? ($optarg eq '')
- : !(defined $rest || @ARGV > 0) ) {
- # Complain if this option needs an argument.
- if ( $mand eq "=" ) {
- return (0) if $passthrough;
- warn ("Option ", $opt, " requires an argument\n");
- $error++;
- undef $opt;
- }
- return (1, $opt, $type eq "s" ? '' : 0, $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 $prevconfig =
- [ $error, $debug, $major_version, $minor_version,
- $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
- $gnu_compat, $passthrough, $genprefix ];
-
- if ( ref($options[0]) eq 'ARRAY' ) {
- ( $error, $debug, $major_version, $minor_version,
- $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
- $gnu_compat, $passthrough, $genprefix ) = @{shift(@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') && $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;
- }
- elsif ( $try eq 'getopt_compat' ) {
- $getopt_compat = $action;
- }
- elsif ( $try eq 'gnu_getopt' ) {
- if ( $action ) {
- $gnu_compat = 1;
- $bundling = 1;
- $getopt_compat = 0;
- $permute = 1;
- }
- }
- elsif ( $try eq 'gnu_compat' ) {
- $gnu_compat = $action;
- }
- elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
- $ignorecase = $action;
- }
- 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=(.+)$/ && $action ) {
- $genprefix = $1;
- # Turn into regexp. Needs to be parenthesized!
- $genprefix = "(" . quotemeta($genprefix) . ")";
- eval { '' =~ /$genprefix/; };
- Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
- }
- elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
- $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\"")
- }
- }
- $prevconfig;
-}
-
-# 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
-
-Getopt::Long - Extended processing of command line options
-
-=head1 SYNOPSIS
-
- use Getopt::Long;
- $result = GetOptions (...option-descriptions...);
-
-=head1 DESCRIPTION
-
-The Getopt::Long module implements an extended getopt function called
-GetOptions(). This function adheres to the POSIX syntax for command
-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.
-
-=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<options> 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
-
- --size 24
-
-The C<+> form is now obsolete and strongly deprecated.
-
-=head1 Getting Started with Getopt::Long
-
-Getopt::Long is the Perl5 successor of C<newgetopt.pl>. 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<->.
-
-To use Getopt::Long from a Perl program, you must include the
-following line in your Perl program:
-
- use Getopt::Long;
-
-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.
-
-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<Configuring Getopt::Long> for more
-details on how to configure Getopt::Long.
-
-=head2 Simple options
-
-The most simple options are the ones that take no values. Their mere
-presence on the command line enables the option. Popular examples are:
-
- --all --verbose --quiet --debug
-
-Handling simple options is straightforward:
-
- my $verbose = ''; # option variable with default value (false)
- my $all = ''; # option variable with default value (false)
- GetOptions ('verbose' => \$verbose, 'all' => \$all);
-
-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<enabling> the option.
-
-The option name as specified to the GetOptions() function is called
-the option I<specification>. 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<destination>.
-
-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<negatable> options and I<incremental> options.
-
-A negatable option is specified with a 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<not> 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<s>. The equals sign indicates that this
-option requires a value. The letter C<s> indicates that this value is
-an arbitrary string. Other possible value types are C<i> for integer
-values, and C<f> 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:
-
- my @libfiles = ();
- GetOptions ("library=s" => \@libfiles);
-
-Used with the example above, 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:
-
- my @libfiles = ();
- 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 I<key>C<=>I<value>. The value will
-be stored with the specified key in the hash.
-
- my %defines = ();
- GetOptions ("define=s" => \%defines);
-
-When used with command line options:
-
- --define os=linux --define vendor=redhat
-
-the hash 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 arguments: the name of the option,
-and the value to be assigned. 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<die("!FINISH")> 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<primary> name, the other names are
-called I<aliases>.
-
-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
-
-=item !
-
-The option does not take an argument and may be negated, i.e. prefixed
-by "no". E.g. C<"foo!"> will allow C<--foo> (a value of 1 will be
-assigned) and C<--nofoo> (a value of 0 will be assigned). If the
-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 +
-
-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 C<+> specifier is ignored if the option destination is not a scalar.
-
-=item = I<type> [ I<desttype> ]
-
-The option requires an argument of the given type. Supported types
-are:
-
-=over
-
-=item s
-
-String. An arbitrary sequence of characters. It is valid for the
-argument to start with C<-> or C<-->.
-
-=item i
-
-Integer. An optional leading plus or minus sign, followed by a
-sequence of digits.
-
-=item f
-
-Real number. For example C<3.14>, C<-6.23E24> and so on.
-
-=back
-
-The I<desttype> 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.
-
-=item : I<type> [ I<desttype> ]
-
-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.
-
-Note that if a string argument starts with C<-> or C<-->, it will be
-considered an option on itself.
-
-=back
-
-=head1 Advanced Possibilities
-
-=head2 Object oriented interface
-
-Getopt::Long can be used in an object oriented way as well:
-
- use Getopt::Long;
- $p = new Getopt::Long::Parser;
- $p->configure(...configuration options...);
- if ($p->getoptions(...options descriptions...)) ...
-
-Configuration options can be passed to the constructor:
-
- $p = new Getopt::Long::Parser
- config => [...configuration options...];
-
-For thread safety, each method call will acquire an exclusive lock to
-the Getopt::Long module. So don't call these methods from a callback
-routine!
-
-=head2 Documentation and help texts
-
-Getopt::Long encourages the use of Pod::Usage to produce help
-messages. For example:
-
- use Getopt::Long;
- use Pod::Usage;
-
- my $man = 0;
- my $help = 0;
-
- GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
- pod2usage(1) if $help;
- pod2usage(-exitstatus => 0, -verbose => 2) if $man;
-
- __END__
-
- =head1 NAME
-
- sample - Using GetOpt::Long and Pod::Usage
-
- =head1 SYNOPSIS
-
- sample [options] [file ...]
-
- Options:
- -help brief help message
- -man full documentation
-
- =head1 OPTIONS
-
- =over 8
-
- =item B<-help>
-
- Print a brief help message and exits.
-
- =item B<-man>
-
- Prints the manual page and exits.
-
- =back
-
- =head1 DESCRIPTION
-
- B<This program> will read the given input file(s) and do someting
- useful with the contents thereof.
-
- =cut
-
-See L<Pod::Usage> for details.
-
-=head2 Storing options in a hash
-
-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.
-
-To obtain this, a reference to a hash must be passed I<as the first
-argument> 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<exists($h{option})> (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<use strict> and uses C<$h{option}> without testing with
-exists() or defined() first.
-
- my %h = ();
- GetOptions (\%h, 'length=i'); # will store in $h{length}
-
-For options that take list or hash values, it is necessary to indicate
-this by appending an C<@> or C<%> sign after the type:
-
- GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
-
-To make things more complicated, the hash may contain references to
-the actual destinations, for example:
-
- my $len = 0;
- my %h = ('length' => \$len);
- GetOptions (\%h, 'length=i'); # will store in $len
-
-This example is fully equivalent with:
-
- my $len = 0;
- GetOptions ('length=i' => \$len); # will store in $len
-
-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:
-
- 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 ... }
-
-=head2 Bundling
-
-With bundling it is possible to set several single-character options
-at once. For example if C<a>, C<v> and C<x> are all valid options,
-
- -vax
-
-would set all three.
-
-Getopt::Long supports two levels of bundling. To enable bundling, a
-call to Getopt::Long::Configure is required.
-
-The first level of bundling can be enabled with:
-
- Getopt::Long::Configure ("bundling");
-
-Configured this way, single-character options can be bundled but long
-options B<must> always start with a double dash C<--> to avoid
-abiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
-options,
-
- -vax
-
-would set C<a>, C<v> and C<x>, but
-
- --vax
-
-would set C<vax>.
-
-The second level of bundling lifts this restriction. It can be enabled
-with:
-
- Getopt::Long::Configure ("bundling_override");
-
-Now, C<-vax> would set the option C<vax>.
-
-When any level of bundling is enabled, option values may be inserted
-in the bundle. For example:
-
- -h24w80
-
-is equivalent to
-
- -h 24 -w 80
-
-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:
-
- Getopt::Long::Configure ("bundling", "ignorecase_always");
-
-It goes without saying that bundling can be quite confusing.
-
-=head2 The lonesome dash
-
-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>.
-
-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:
-
- GetOptions ('' => \$stdio);
-
-A lone dash on the command line will now be a legal option, and using
-it will set variable C<$stdio>.
-
-=head2 Argument call-back
-
-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 the argument as a parameter.
-
-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<process("arg1")> while C<$width> is C<80>,
-C<process("arg2")> while C<$width> is C<72>, and
-C<process("arg3")> while C<$width> is C<60>.
-
-This feature requires configuration option B<permute>, see section
-L<Configuring Getopt::Long>.
-
-
-=head1 Configuring Getopt::Long
-
-Getopt::Long can be configured by calling subroutine
-Getopt::Long::Configure(). This subroutine takes a list of quoted
-strings, each specifying a configuration option to be enabled, e.g.
-C<ignore_case>, or disabled, e.g. C<no_ignore_case>. 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<use> statement:
-
- use Getopt::Long qw(:config no_ignore_case bundling);
-
-The following options are available:
-
-=over 12
-
-=item default
-
-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 enabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<auto_abbrev> 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<getopt_compat> is disabled.
-
-=item gnu_compat
-
-C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
-do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
-C<--opt=> will give option C<opt> and empty value.
-This is the way GNU getopt_long() does it.
-
-=item gnu_getopt
-
-This is a short way of setting C<gnu_compat> C<bundling> C<permute>
-C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
-fully compatible with GNU getopt_long().
-
-=item require_order
-
-Whether command line arguments are allowed to be mixed with options.
-Default is disabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
-
-See also C<permute>, which is the opposite of C<require_order>.
-
-=item permute
-
-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<permute> is disabled.
-Note that C<permute> is the opposite of C<require_order>.
-
-If C<permute> is enabled, this means that
-
- --foo arg1 --bar arg2 arg3
-
-is equivalent to
-
- --foo --bar arg1 arg2 arg3
-
-If an argument call-back 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
-
-will call the call-back routine for arg1 and arg2, and terminate
-GetOptions() leaving C<"arg2"> in C<@ARGV>.
-
-If C<require_order> is enabled, options processing
-terminates when the first non-option is encountered.
-
- --foo arg1 --bar arg2 arg3
-
-is equivalent to
-
- --foo -- arg1 --bar arg2 arg3
-
-If C<pass_through> is also enabled, options processing will terminate
-at the first unrecognized option, or non-option, whichever comes
-first.
-
-=item bundling (default: disabled)
-
-Enabling this option will allow single-character options to be bundled.
-To distinguish bundles from long option names, long options I<must> be
-introduced with C<--> and single-character options (and bundles) with
-C<->.
-
-Note: disabling C<bundling> also disables C<bundling_override>.
-
-=item bundling_override (default: disabled)
-
-If C<bundling_override> is enabled, bundling is enabled as with
-C<bundling> but now long option names override option bundles.
-
-Note: disabling C<bundling_override> also disables C<bundling>.
-
-B<Note:> Using option bundling can easily lead to unexpected results,
-especially when mixing long options and bundles. Caveat emptor.
-
-=item ignore_case (default: enabled)
-
-If enabled, case is ignored when matching long option names. Single
-character options will be treated case-sensitive.
-
-Note: disabling C<ignore_case> also disables C<ignore_case_always>.
-
-=item ignore_case_always (default: disabled)
-
-When bundling is in effect, case is ignored on single-character
-options also.
-
-Note: disabling C<ignore_case_always> also disables C<ignore_case>.
-
-=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.
-
-If C<require_order> is enabled, options processing will terminate at
-the first unrecognized option, or non-option, whichever comes first.
-However, if C<permute> is enabled instead, results can become confusing.
-
-=item prefix
-
-The string that starts options. If a constant string is not
-sufficient, see C<prefix_pattern>.
-
-=item prefix_pattern
-
-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: disabled)
-
-Enable debugging output.
-
-=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<eval { ...
-}>, 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__}>.
-
-Errors that can't happen are signalled using Carp::croak().
-
-=head1 Legacy
-
-The earliest development of C<newgetopt.pl> 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 C<opt_>I<XXX>, where
-I<XXX> is the primary name of this option. When a progam executes
-under C<use strict> (recommended), these variables must be
-pre-declared with our() or C<use vars>.
-
- 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<main>. 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<using a starter
-argument is strongly deprecated> 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<Configure> routine that was introduced
-in version 2.17. Besides, it is much easier.
-
-=head1 Trouble Shooting
-
-=head2 Warning: Ignoring '!' modifier for short option
-
-This warning is issued when the '!' modifier is applied to a short
-(one-character) option and bundling is in effect. E.g.,
-
- Getopt::Long::Configure("bundling");
- GetOptions("foo|f!" => \$foo);
-
-Note that older Getopt::Long versions did not issue a warning, because
-the '!' modifier was applied to the first name only. This bug was
-fixed in 2.22.
-
-Solution: separate the long and short names and apply the '!' to the
-long names only, e.g.,
-
- GetOptions("foo!" => \$foo, "f" => \$foo);
-
-=head2 GetOptions does not return a false result when an option is not supplied
-
-That's why they're called 'options'.
-
-=head1 AUTHOR
-
-Johan Vromans <jvromans@squirrel.nl>
-
-=head1 COPYRIGHT AND DISCLAIMER
-
-This program is Copyright 2000,1990 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.
-
-=cut
-
-# Local Variables:
-# eval: (load-file "pod.el")
-# End:
diff --git a/contrib/perl5/lib/Getopt/Std.pm b/contrib/perl5/lib/Getopt/Std.pm
deleted file mode 100644
index e5b369c..0000000
--- a/contrib/perl5/lib/Getopt/Std.pm
+++ /dev/null
@@ -1,176 +0,0 @@
-package Getopt::Std;
-require 5.000;
-require Exporter;
-
-=head1 NAME
-
-getopt - Process single-character switches with switch clustering
-
-getopts - Process single-character switches with switch clustering
-
-=head1 SYNOPSIS
-
- use Getopt::Std;
-
- getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
- getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
- getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
- # Sets opt_* as a side effect.
- getopts('oif:', \%opts); # options as above. Values in %opts
-
-=head1 DESCRIPTION
-
-The getopt() functions processes single-character switches with switch
-clustering. Pass one argument which is a string containing all switches
-that take an argument. For each switch found, sets $opt_x (where x is the
-switch name) to the value of the argument, or 1 if no argument. Switches
-which take an argument don't care whether there is a space between the
-switch and the argument.
-
-Note that, if your code is running under the recommended C<use strict
-'vars'> pragma, you will need to declare these package variables
-with "our":
-
- our($opt_foo, $opt_bar);
-
-For those of you who don't like additional global variables being created, getopt()
-and getopts() will also accept a hash reference as an optional second argument.
-Hash keys will be x (where x is the switch name) with key values the value of
-the argument or 1 if no argument is specified.
-
-To allow programs to process arguments that look like switches, but aren't,
-both functions will stop processing switches when they see the argument
-C<-->. The C<--> will be removed from @ARGV.
-
-=cut
-
-@ISA = qw(Exporter);
-@EXPORT = qw(getopt getopts);
-$VERSION = '1.02';
-
-# Process single-character switches with switch clustering. Pass one argument
-# which is a string containing all switches that take an argument. For each
-# switch found, sets $opt_x (where x is the switch name) to the value of the
-# argument, or 1 if no argument. Switches which take an argument don't care
-# whether there is a space between the switch and the argument.
-
-# Usage:
-# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
-
-sub getopt ($;$) {
- local($argumentative, $hash) = @_;
- local($_,$first,$rest);
- local @EXPORT;
-
- while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
- ($first,$rest) = ($1,$2);
- if (/^--$/) { # early exit if --
- shift @ARGV;
- last;
- }
- if (index($argumentative,$first) >= 0) {
- if ($rest ne '') {
- shift(@ARGV);
- }
- else {
- shift(@ARGV);
- $rest = shift(@ARGV);
- }
- if (ref $hash) {
- $$hash{$first} = $rest;
- }
- else {
- ${"opt_$first"} = $rest;
- push( @EXPORT, "\$opt_$first" );
- }
- }
- else {
- if (ref $hash) {
- $$hash{$first} = 1;
- }
- else {
- ${"opt_$first"} = 1;
- push( @EXPORT, "\$opt_$first" );
- }
- if ($rest ne '') {
- $ARGV[0] = "-$rest";
- }
- else {
- shift(@ARGV);
- }
- }
- }
- unless (ref $hash) {
- local $Exporter::ExportLevel = 1;
- import Getopt::Std;
- }
-}
-
-# Usage:
-# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
-# # side effect.
-
-sub getopts ($;$) {
- local($argumentative, $hash) = @_;
- local(@args,$_,$first,$rest);
- local($errs) = 0;
- local @EXPORT;
-
- @args = split( / */, $argumentative );
- while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
- ($first,$rest) = ($1,$2);
- if (/^--$/) { # early exit if --
- shift @ARGV;
- last;
- }
- $pos = index($argumentative,$first);
- if ($pos >= 0) {
- if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
- shift(@ARGV);
- if ($rest eq '') {
- ++$errs unless @ARGV;
- $rest = shift(@ARGV);
- }
- if (ref $hash) {
- $$hash{$first} = $rest;
- }
- else {
- ${"opt_$first"} = $rest;
- push( @EXPORT, "\$opt_$first" );
- }
- }
- else {
- if (ref $hash) {
- $$hash{$first} = 1;
- }
- else {
- ${"opt_$first"} = 1;
- push( @EXPORT, "\$opt_$first" );
- }
- if ($rest eq '') {
- shift(@ARGV);
- }
- else {
- $ARGV[0] = "-$rest";
- }
- }
- }
- else {
- warn "Unknown option: $first\n";
- ++$errs;
- if ($rest ne '') {
- $ARGV[0] = "-$rest";
- }
- else {
- shift(@ARGV);
- }
- }
- }
- unless (ref $hash) {
- local $Exporter::ExportLevel = 1;
- import Getopt::Std;
- }
- $errs == 0;
-}
-
-1;
--
cgit v1.1