This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated to match newer Getopt::Long.
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Wed, 7 Feb 1996 02:16:07 +0000 (02:16 +0000)
committerAndy Dougherty <doughera@lafcol.lafayette.edu>
Wed, 7 Feb 1996 02:16:07 +0000 (02:16 +0000)
lib/newgetopt.pl

index 0e4cbfd..38cad59 100644 (file)
-# 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.15 1995/12/26 14:57:33 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;
     }
-
-    # 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;
     }
 
-    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::ignorecase = $newgetopt::ignorecase 
+       if defined $newgetopt::ignorecase;
+
+    &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 ################