Newgetopt.pl, version 1.13. 
Author Message
 Newgetopt.pl, version 1.13.


Archive-name: newgetopt.pl-1.13

This is a new (updated) version of perl's newgetopt.pl.

Major new functionality: options can be designated of type array,
which means that

        command -bar x1 -bar x2 -bar x3 ...


#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#

# Source directory /nfs/pronto/mozart/users/jv/src/newgetopt
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   7685 -r--r--r-- newgetopt.pl
#
# ============= newgetopt.pl ==============
if test -f 'newgetopt.pl' -a X"$1" != X"-c"; then
        echo 'x - skipping newgetopt.pl (File already exists)'
else
echo 'x - extracting newgetopt.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'newgetopt.pl' &&
X# newgetopt.pl -- new options parsing
X

X# Author          : Johan Vromans
X# Created On      : Tue Sep 11 15:00:12 1990
X# Last Modified By: Johan Vromans
X# Last Modified On: Tue Jun  2 11:24:03 1992
X# Update Count    : 75
X# Status          : Okay
X
X# This package implements a new getopt function. This function adheres
X# to the new syntax (long option names, no bundling).
X#
X# Arguments to the function are:
X#
X#  - a list of possible options. These should designate valid perl
X#    identifiers, optionally followed by an argument specifier ("="
X#    for mandatory arguments or ":" for optional arguments) and an
X#    argument type specifier: "n" or "i" for integer numbers, "f" for
X#    real (fix) numbers or "s" for strings.

X#    Value(s) are not set, but pushed.
X#
X#  - if the first option of the list consists of non-alphanumeric
X#    characters only, it is interpreted as a generic option starter.
X#    Everything starting with one of the characters from the starter
X#    will be considered an option.
X#    Likewise, a double occurrence (e.g. "--") signals end of
X#    the options list.
X#    The default value for the starter is "-", "--" or "+".
X#
X# Upon return, the option variables, prefixed with "opt_", are defined
X# and set to the respective option arguments, if any.
X# Options that do not take an argument are set to 1. Note that an
X# option with an optional argument will be defined, but set to '' if
X# no actual argument has been supplied.
X# A return status of 0 (false) indicates that the function detected
X# one or more errors.
X#
X# Special care is taken to give a correct treatment to optional arguments.
X#
X# E.g. if option "one:i" (i.e. takes an optional integer argument),
X# then the following situations are handled:
X#
X#    -one -two         -> $opt_one = '', -two is next option
X#    -one -2           -> $opt_one = -2
X#
X# Also, assume "foo=s" and "bar:s" :
X#
X#    -bar -xxx         -> $opt_bar = '', '-xxx' is next option
X#    -foo -bar         -> $opt_foo = '-bar'
X#    -foo --           -> $opt_foo = '--'
X#
X# HISTORY
X# 2-Jun-1992           Johan Vromans  
X#    Do not use //o to allow multiple NGetOpt calls with different delimeters.
X#    Prevent typeless option from using previous $array state.
X#    Prevent empty option from being eaten as a (negative) number.
X
X# 25-May-1992          Johan Vromans  

X#    contains all values that were supplied. E.g. "-foo one -foo -two" will

X#    Correct bug in handling options that allow for a argument when followed
X#    by another option.
X
X# 4-May-1992           Johan Vromans  
X#    Add $ignorecase to match options in either case.
X#    Allow '' option.
X
X# 19-Mar-1992          Johan Vromans  
X#    Allow require from packages.
X#    NGetOpt is now defined in the package that requires it.

X#    Use standard (?) option prefixes: -, -- and +.
X
X# 20-Sep-1990          Johan Vromans  
X#    Set options w/o argument to 1.
X#    Correct the dreadful semicolon/require bug.
X
X
X{   package newgetopt;
X    $debug = 0;                        # for debugging
X    $ignorecase = 1;           # ignore case when matching options
X}
X
Xsub NGetOpt {
X

X    *newgetopt'ARGV = *ARGV;
X
X    package newgetopt;
X
X    local ($[) = 0;
X    local ($genprefix) = "(--|-|\\+)";
X    local ($argend) = "--";
X    local ($error) = 0;
X    local ($opt, $optx, $arg, $type, $mand, %opctl);
X    local ($pkg) = (caller)[0];
X
X    print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
X
X    # See if the first element of the optionlist contains option
X    # starter characters.
X    if ( $optionlist[0] =~ /^\W+$/ ) {

X       # Turn into regexp.
X       $genprefix =~ s/(\W)/\\\1/g;
X       $genprefix = "[" . $genprefix . "]";
X       undef $argend;
X    }
X
X    # Verify correctness of optionlist.
X    %opctl = ();

X       $opt =~ tr/A-Z/a-z/ if $ignorecase;

X           print STDERR ("Error in option spec: \"", $opt, "\"\n");
X           $error++;
X           next;
X       }
X       $opctl{$1} = defined $2 ? $2 : "";
X    }
X
X    return 0 if $error;
X
X    if ( $debug ) {
X       local ($arrow, $k, $v);
X       $arrow = "=> ";
X       while ( ($k,$v) = each(%opctl) ) {
X           print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
X           $arrow = "   ";
X       }
X    }
X
X    # Process argument list
X
X    while ( $#ARGV >= 0 ) {
X
X       # >>> See also the continue block <<<
X
X       # Get next argument

X       print STDERR ("=> option \"", $opt, "\"\n") if $debug;
X       $arg = undef;
X
X       # Check for exhausted list.
X       if ( $opt =~ /^$genprefix/ ) {
X           # Double occurrence is terminator
X           return ($error == 0)
X               if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
X           $opt = $';          # option name (w/o prefix)
X       }
X       else {
X           # Apparently not an option - push back and exit.

X           return ($error == 0);
X       }
X
X       # Look it up.
X       $opt =~ tr/A-Z/a-z/ if $ignorecase;
X       unless  ( defined ( $type = $opctl{$opt} ) ) {
X           print STDERR ("Unknown option: ", $opt, "\n");
X           $error++;
X           next;
X       }
X
X       # Determine argument status.
X       print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
X
X       # If it is an option w/o argument, we're almost finished with it.
X       if ( $type eq "" ) {
X           $arg = 1;           # supply explicit value
X           $array = 0;
X           next;
X       }
X
X       # Get mandatory status and type info.

X
X       # Check if the argument list is exhausted.
X       if ( $#ARGV < 0 ) {
X
X           # Complain if this option needs an argument.
X           if ( $mand eq "=" ) {
X               print STDERR ("Option ", $opt, " requires an argument\n");
X               $error++;
X           }
X           if ( $mand eq ":" ) {
X               $arg = $type eq "s" ? "" : 0;
X           }
X           next;
X       }
X
X       # Get (possibly optional) argument.

X
X       # Check if it is a valid argument. A mandatory string takes
X       # anything.
X       if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
X
X           # Check for option list terminator.
X           if ( $arg eq "$+$+" ||
X                ((defined $argend) && $arg eq $argend)) {
X               # Push back so the outer loop will terminate.

X               # Complain if an argument is required.
X               if ($mand eq "=") {
X                   print STDERR ("Option ", $opt, " requires an argument\n");
X                   $error++;
X                   undef $arg; # don't assign it
X               }
X               else {
X                   # Supply empty value.
X                   $arg = $type eq "s" ? "" : 0;
X               }
X               next;
X           }
X
X           # Maybe the optional argument is the next option?
X           if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
X               # Yep. Push back.

X               $arg = $type eq "s" ? "" : 0;
X               next;
X           }
X       }
X
X       if ( $type eq "n" || $type eq "i" ) { # numeric/integer
X           if ( $arg !~ /^-?[0-9]+$/ ) {
X               print STDERR ("Value \"", $arg, "\" invalid for option ",
X                             $opt, " (number expected)\n");
X               $error++;
X               undef $arg;     # don't assign it
X           }
X           next;
X       }
X
X       if ( $type eq "f" ) { # fixed real number, int is also ok
X           if ( $arg !~ /^-?[0-9.]+$/ ) {
X               print STDERR ("Value \"", $arg, "\" invalid for option ",
X                             $opt, " (real number expected)\n");
X               $error++;
X               undef $arg;     # don't assign it
X           }
X           next;
X       }
X
X       if ( $type eq "s" ) { # string
X           next;
X       }
X
X    }
X    continue {
X       if ( defined $arg ) {
X           if ( $array ) {

X                   if $debug;

X           }
X           else {
X               print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
X                   if $debug;
X               eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
X           }
X       }
X    }
X
X    return ($error == 0);
X}
X1;
SHAR_EOF
chmod 0444 newgetopt.pl ||
echo 'restore of newgetopt.pl failed'
Wc_c="`wc -c < 'newgetopt.pl'`"
test 7685 -eq "$Wc_c" ||
        echo 'newgetopt.pl: original size 7685, current size' "$Wc_c"
fi
exit 0
--

Multihouse Automatisering bv                   uucp:..!{uunet,sun4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: +31 1820 62911/62500
------------------------ "Arms are made for hugging" -------------------------



Sun, 20 Nov 1994 00:14:50 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. newgetopt.pl by Johan Vromans version 1.13

2. Source: newgetopt.pl version 1.14

3. DBI object version 1.13 does not match

4. abbrev.pl + newgetopt.pl = NEAT!

5. Changes to NGetOpt in newgetopt.pl

6. Abbreviation support for newgetopt.pl

7. any additional docs for newgetopt.pl?

8. newgetopt.pl

9. Official patch to newgetopt.pl 1.9

10. bug in newgetopt.pl

11. newgetopt.pl

12. newgetopt.pl dumps core

 

 
Powered by phpBB® Forum Software