X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnewgetopt.pl;h=0b7eed8bfe91e313222e2ef4c1e5813ff78a2a31;hb=09b7f37c58c6da6f4965b846b64eab7d9a205663;hp=87824289615dbe7e4e093caf16e5ed3b78356201;hpb=45d8adaa83210dbf286f70ae01d99f534e6c8052;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl
index 8782428..0b7eed8 100644
--- a/lib/newgetopt.pl
+++ b/lib/newgetopt.pl
@@ -1,207 +1,68 @@
-# newgetopt.pl -- new options parsing
-
-# SCCS Status     : @(#)@ newgetopt.pl	1.8
-# Author          : Johan Vromans
-# Created On      : Tue Sep 11 15:00:12 1990
-# Last Modified By: Johan Vromans
-# Last Modified On: Thu Sep 26 20:10:41 1991
-# Update Count    : 35
-# 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 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 "-".
-#
-# 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 
-# 20-Sep-1990		Johan Vromans	
-#    Set options w/o argument to 1.
-#    Correct the dreadful semicolon/require bug.
-
-
-package newgetopt;
-
-$debug = 0;			# for debugging
-
-sub main'NGetOpt {
-    local (@optionlist) = @_;
-    local ($[) = 0;
-    local ($genprefix) = "-";
-    local ($error) = 0;
-    local ($opt, $optx, $arg, $type, $mand, @hits);
-
-    # See if the first element of the optionlist contains option
-    # starter characters.
-    $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
-
-    # Turn into regexp.
-    $genprefix =~ s/(\W)/\\\1/g;
-    $genprefix = "[" . $genprefix . "]";
-
-    # Verify correctness of optionlist.
-    @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
-    if ( $#hits >= 0 ) {
-	foreach $opt ( @hits ) {
-	    print STDERR ("Error in option spec: \"", $opt, "\"\n");
-	    $error++;
-	}
-	return 0;
+# 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;
+
+    # 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;
+    }
+    else {
+	$autoabbrev = 1;	# automatic abbrev of options
+	$getopt_compat = 1;	# allow '+' to start options
+	$option_start = "(--|-|\\+)";
+	$order = $PERMUTE;
+	$bundling = 0;
+	$passthrough = 0;
     }
 
-    # Process argument list
-
-    while ( $#main'ARGV >= 0 ) {		#'){
-
-	# >>> See also the continue block <<<
-
-	# Get next argument
-	$opt = shift (@main'ARGV);		#');
-	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
-	$arg = undef;
-
-	# Check for exhausted list.
-	if ( $opt =~ /^$genprefix/o ) {
-	    # Double occurrence is terminator
-	    return ($error == 0) if $opt eq "$+$+";
-	    $opt = $';		# option name (w/o prefix)
-	}
-	else {
-	    # Apparently not an option - push back and exit.
-	    unshift (@main'ARGV, $opt);		#');
-	    return ($error == 0);
-	}
-
-	# Grep in option list. Hide regexp chars from option.
-	($optx = $opt) =~ s/(\W)/\\\1/g;
-	@hits = grep (/^$optx([=:].+)?$/, @optionlist);
-	if ( $#hits != 0 ) {
-	    print STDERR ("Unknown option: ", $opt, "\n");
-	    $error++;
-	    next;
-	}
-
-	# Determine argument status.
-	undef $type;
-	$type = $+ if $hits[0] =~ /[=:].+$/;
-	print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
-
-	# If it is an option w/o argument, we're almost finished with it.
-	if ( ! defined $type ) {
-	    $arg = 1;		# supply explicit value
-	    next;
-	}
-
-	# Get mandatory status and type info.
-	($mand, $type) = $type =~ /^(.)(.)$/;
-
-	# Check if the argument list is exhausted.
-	if ( $#main'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 (@main'ARGV);		#');
-
-	# Check if it is a valid argument. A mandatory string takes
- 	# anything. 
-	if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
-
-	    # Check for option list terminator.
-	    if ( $arg eq "$+$+" ) {
-		# Complain if an argument is required.
-		if ($mand eq "=") {
-		    print STDERR ("Option ", $opt, " requires an argument\n");
-		    $error++;
-		}
-		# Push back so the outer loop will terminate.
-		unshift (@main'ARGV, $arg);	#');
-		$arg = "";	# don't assign it
-		next;
-	    }
-
-	    # Maybe the optional argument is the next option?
-	    if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
-		# Yep. Push back.
-		unshift (@main'ARGV, $arg);	#');
-		$arg = "";	# don't assign it
-		next;
-	    }
-	}
-
-	if ( $type eq "n" || $type eq "i" ) { # numeric/integer
-	    if ( $arg !~ /^-?[0-9]+$/ ) {
-		print STDERR ("Value \"", $arg, "\" invalid for option ",
-			       $opt, " (numeric required)\n");
-		$error++;
-	    }
-	    next;
-	}
-
-	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 required)\n");
-		$error++;
-	    }
-	    next;
-	}
+    # Other configurable settings.
+    $debug = 0;			# for debugging
+    $ignorecase = 1;		# ignore case when matching options
+    $argv_end = "--";		# don't change this!
+}
 
-	if ( $type eq "s" ) { # string
-	    next;
-	}
+use Getopt::Long;
+
+################ Subroutines ################
+
+sub NGetOpt {
+
+    $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 {
-	print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
-	eval ("\$main'opt_$opt = \$arg");
-    }
+################ Package return ################
 
-    return ($error == 0);
-}
 1;
+
+################ End of newgetopt.pl ################