X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnewgetopt.pl;h=0b7eed8bfe91e313222e2ef4c1e5813ff78a2a31;hb=f1612b5c9ea43d9872ae3595ce140e5a62ae6cf4;hp=0e4cbfd49ab942046dbda3991e20a6bbaa22a5c4;hpb=ee0007abcec11102eeaa49662e5ebb838e04aac6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl index 0e4cbfd..0b7eed8 100644 --- a/lib/newgetopt.pl +++ b/lib/newgetopt.pl @@ -1,271 +1,68 @@ -# newgetopt.pl -- new options parsing - -# SCCS Status : @(#)@ newgetopt.pl 1.13 -# Author : Johan Vromans -# Created On : Tue Sep 11 15:00:12 1990 -# Last Modified By: Johan Vromans -# Last Modified On: Tue Jun 2 11:24:03 1992 -# Update Count : 75 -# Status : Okay - -# This package implements a new getopt function. This function adheres -# to the new syntax (long option names, no bundling). -# -# Arguments to the function are: -# -# - a list of possible options. These should designate valid perl -# identifiers, optionally followed by an argument specifier ("=" -# for mandatory arguments or ":" for optional arguments) and an -# argument type specifier: "n" or "i" for integer numbers, "f" for -# real (fix) numbers or "s" for strings. -# If an "@" sign is appended, the option is treated as an array. -# Value(s) are not set, but pushed. -# -# - if the first option of the list consists of non-alphanumeric -# characters only, it is interpreted as a generic option starter. -# Everything starting with one of the characters from the starter -# will be considered an option. -# Likewise, a double occurrence (e.g. "--") signals end of -# the options list. -# The default value for the starter is "-", "--" or "+". -# -# Upon return, the option variables, prefixed with "opt_", are defined -# and set to the respective option arguments, if any. -# Options that do not take an argument are set to 1. Note that an -# option with an optional argument will be defined, but set to '' if -# no actual argument has been supplied. -# A return status of 0 (false) indicates that the function detected -# one or more errors. -# -# Special care is taken to give a correct treatment to optional arguments. -# -# E.g. if option "one:i" (i.e. takes an optional integer argument), -# then the following situations are handled: -# -# -one -two -> $opt_one = '', -two is next option -# -one -2 -> $opt_one = -2 -# -# Also, assume "foo=s" and "bar:s" : -# -# -bar -xxx -> $opt_bar = '', '-xxx' is next option -# -foo -bar -> $opt_foo = '-bar' -# -foo -- -> $opt_foo = '--' -# -# HISTORY -# 2-Jun-1992 Johan Vromans -# Do not use //o to allow multiple NGetOpt calls with different delimeters. -# Prevent typeless option from using previous $array state. -# Prevent empty option from being eaten as a (negative) number. - -# 25-May-1992 Johan Vromans -# Add array options. "foo=s@" will return an array @opt_foo that -# contains all values that were supplied. E.g. "-foo one -foo -two" will -# return @opt_foo = ("one", "-two"); -# Correct bug in handling options that allow for a argument when followed -# by another option. - -# 4-May-1992 Johan Vromans -# Add $ignorecase to match options in either case. -# Allow '' option. - -# 19-Mar-1992 Johan Vromans -# Allow require from packages. -# NGetOpt is now defined in the package that requires it. -# @ARGV and $opt_... are taken from the package that calls it. -# Use standard (?) option prefixes: -, -- and +. - -# 20-Sep-1990 Johan Vromans -# Set options w/o argument to 1. -# Correct the dreadful semicolon/require bug. - +# newgetopt.pl -- new options parsing. +# Now just a wrapper around the Getopt::Long module. +# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $ { package newgetopt; - $debug = 0; # for debugging - $ignorecase = 1; # ignore case when matching options -} -sub NGetOpt { - - @newgetopt'optionlist = @_; - *newgetopt'ARGV = *ARGV; - - package newgetopt; - - local ($[) = 0; - local ($genprefix) = "(--|-|\\+)"; - local ($argend) = "--"; - local ($error) = 0; - local ($opt, $optx, $arg, $type, $mand, %opctl); - local ($pkg) = (caller)[0]; - - print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug; - - # 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 . "]"; - undef $argend; + # Values for $order. See GNU getopt.c for details. + $REQUIRE_ORDER = 0; + $PERMUTE = 1; + $RETURN_IN_ORDER = 2; + + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $autoabbrev = 0; # no automatic abbrev of options (???) + $getopt_compat = 0; # disallow '+' to start options + $option_start = "(--|-)"; + $order = $REQUIRE_ORDER; + $bundling = 0; + $passthrough = 0; } - - # Verify correctness of optionlist. - %opctl = (); - foreach $opt ( @optionlist ) { - $opt =~ tr/A-Z/a-z/ if $ignorecase; - if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) { - print STDERR ("Error in option spec: \"", $opt, "\"\n"); - $error++; - next; - } - $opctl{$1} = defined $2 ? $2 : ""; + else { + $autoabbrev = 1; # automatic abbrev of options + $getopt_compat = 1; # allow '+' to start options + $option_start = "(--|-|\\+)"; + $order = $PERMUTE; + $bundling = 0; + $passthrough = 0; } - return 0 if $error; - - if ( $debug ) { - local ($arrow, $k, $v); - $arrow = "=> "; - while ( ($k,$v) = each(%opctl) ) { - print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); - $arrow = " "; - } - } - - # Process argument list - - while ( $#ARGV >= 0 ) { - - # >>> See also the continue block <<< - - # Get next argument - $opt = shift (@ARGV); - print STDERR ("=> option \"", $opt, "\"\n") if $debug; - $arg = undef; - - # Check for exhausted list. - if ( $opt =~ /^$genprefix/ ) { - # Double occurrence is terminator - return ($error == 0) - if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend); - $opt = $'; # option name (w/o prefix) - } - else { - # Apparently not an option - push back and exit. - unshift (@ARGV, $opt); - return ($error == 0); - } - - # Look it up. - $opt =~ tr/A-Z/a-z/ if $ignorecase; - unless ( defined ( $type = $opctl{$opt} ) ) { - print STDERR ("Unknown option: ", $opt, "\n"); - $error++; - next; - } - - # Determine argument status. - print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; - - # If it is an option w/o argument, we're almost finished with it. - if ( $type eq "" ) { - $arg = 1; # supply explicit value - $array = 0; - next; - } - - # Get mandatory status and type info. - ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; - - # Check if the argument list is exhausted. - if ( $#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; - } - - # Get (possibly optional) argument. - $arg = shift (@ARGV); - - # Check if it is a valid argument. A mandatory string takes - # anything. - if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) { - - # Check for option list terminator. - if ( $arg eq "$+$+" || - ((defined $argend) && $arg eq $argend)) { - # Push back so the outer loop will terminate. - unshift (@ARGV, $arg); - # Complain if an argument is required. - if ($mand eq "=") { - print STDERR ("Option ", $opt, " requires an argument\n"); - $error++; - undef $arg; # don't assign it - } - else { - # Supply empty value. - $arg = $type eq "s" ? "" : 0; - } - next; - } + # Other configurable settings. + $debug = 0; # for debugging + $ignorecase = 1; # ignore case when matching options + $argv_end = "--"; # don't change this! +} - # Maybe the optional argument is the next option? - if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) { - # Yep. Push back. - unshift (@ARGV, $arg); - $arg = $type eq "s" ? "" : 0; - next; - } - } +use Getopt::Long; - if ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $arg !~ /^-?[0-9]+$/ ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); - $error++; - undef $arg; # don't assign it - } - next; - } +################ Subroutines ################ - if ( $type eq "f" ) { # fixed real number, int is also ok - if ( $arg !~ /^-?[0-9.]+$/ ) { - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); - $error++; - undef $arg; # don't assign it - } - next; - } +sub NGetOpt { - if ( $type eq "s" ) { # string - next; - } + $Getopt::Long::debug = $newgetopt::debug + if defined $newgetopt::debug; + $Getopt::Long::autoabbrev = $newgetopt::autoabbrev + if defined $newgetopt::autoabbrev; + $Getopt::Long::getopt_compat = $newgetopt::getopt_compat + if defined $newgetopt::getopt_compat; + $Getopt::Long::option_start = $newgetopt::option_start + if defined $newgetopt::option_start; + $Getopt::Long::order = $newgetopt::order + if defined $newgetopt::order; + $Getopt::Long::bundling = $newgetopt::bundling + if defined $newgetopt::bundling; + $Getopt::Long::ignorecase = $newgetopt::ignorecase + if defined $newgetopt::ignorecase; + $Getopt::Long::ignorecase = $newgetopt::ignorecase + if defined $newgetopt::ignorecase; + $Getopt::Long::passthrough = $newgetopt::passthrough + if defined $newgetopt::passthrough; + + &GetOptions; +} - } - continue { - if ( defined $arg ) { - if ( $array ) { - print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") - if $debug; - eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); - } - else { - print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") - if $debug; - eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); - } - } - } +################ Package return ################ - return ($error == 0); -} 1; + +################ End of newgetopt.pl ################