Source: newgetopt.pl version 1.14 
Author Message
 Source: newgetopt.pl version 1.14

This is a highly improved version of the one and only official
NGetOpt routine, as included in the Perl 4.0 library file "newgetopt.pl".

Changes in version 1.14 (Feb 12, 1994):

- More GNU and POSIX compliancy.

  If environment variable POSIXLY_CORRECT is defined, the syntax
  adheres to the strict POSIX definitions.

- Option names may be abbreviated to uniqueness.

  You can use "-v" instead of "-verbose" as long as the abbreviation
  is unique.

- Option names can have aliases.

  You can set options using different names, e.g. "-center" and
  "-centre" can both set the same option.

- Options can be negatable.

  So you can say "-debug" to set it, and "-nodebug" to reset it.

- Option values can be included in the option itself.

  E.g. "--width=5" is equivalent to "-width 5". Note: not "-width=5".

- Options and arguments can be mixed.

  E.g. "-foo arg1 -bar arg2" is the same as "-foo -bar -- arg1 arg2".

- Greatly enhanced description of usage and configuration values.

Other features of this NGetOpt routine:

- Options can be arrays.


- '-' is a valid option also.

  Corresponding perl variable is $opt_ .

- Options can contain dashes.

  E.g. "-pcc-struct-return" will set the variable $opt_pcc_struct_return.

- Case can be ignored in options.

  "-debug" is equivalent to "-Debug", "-DEBUG", etc.

- Option variables are defined in the package scope NGetOpt is called
  from, not necessarily 'main'.

---- Cut Here and feed the following to sh ----
#!/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 /users/jv
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#  15094 -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: Sat Feb 12 18:24:02 1994
X# Update Count    : 138
X# Status          : Okay
X
X################ Introduction ################
X#
X# This package implements an extended getopt function. This function adheres
X# to the new syntax (long option names, no bundling).
X# It tries to implement the better functionality of traditional, GNU and
X# POSIX getopt functions.
X#
X# This program is Copyright 1990,1994 by Johan Vromans.
X# This program is free software; you can redistribute it and/or
X# modify it under the terms of the GNU General Public License
X# as published by the Free Software Foundation; either version 2
X# of the License, or (at your option) any later version.
X#
X# This program is distributed in the hope that it will be useful,
X# but WITHOUT ANY WARRANTY; without even the implied warranty of
X# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X# GNU General Public License for more details.
X#
X# If you do not have a copy of the GNU General Public License write to
X# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
X# MA 02139, USA.
X
X################ Description ################
X#
X# Usage:
X#
X#    require "newgetopt.pl";
X#    ...change configuration values, if needed...
X#    $result = &NGetOpt (...option-descriptions...);
X#
X# Each description should designate a valid perl identifier, optionally
X# followed by an argument specifier.
X#
X# Values for argument specifiers are:
X#
X#   <none>   option does not take an argument
X#   !        option does not take an argument and may be negated
X#   =s :s    option takes a mandatory (=) or optional (:) string argument
X#   =i :i    option takes a mandatory (=) or optional (:) integer argument
X#   =f :f    option takes a mandatory (=) or optional (:) real number argument
X#
X# If option "name" is set, it will cause the perl variable $opt_name to
X# be set to the specified value. The calling program can use this
X# variable to detect whether the option has been set. Options that do
X# not take an argument will be set to 1 (one).
X#
X# Options that take an optional argument will be defined, but set to ''
X# if no actual argument has been supplied.
X#

X# treated as an array. Value(s) are not set, but pushed into array

X#
X# Options that do not take a value may have an "!" argument spacifier to
X# indicate that they may be negated. E.g. "foo!" will allow -foo (which
X# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
X#
X# The option name may actually be a list of option names, separated by
X# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
X# 'blech' will set $opt_foo instead.
X#
X# Option names may be abbreviated to uniqueness, depending on
X# configuration variable $autoabbrev.
X#
X# Dashes in option names are allowed (e.g. pcc-struct-return) and will
X# be translated to underscores in the corresponding perl variable (e.g.
X# $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
X# option, corresponding perl identifier is $opt_ .
X#
X# A double dash "--" signals end of the options list.
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 will
X# be considered an option.
X#
X# The default values for the option starters are "-" (traditional), "--"
X# (POSIX) and "+" (GNU, being phased out).
X#
X# Options that start with "--" may have an argument appended, separated
X# with an "=", e.g. "--foo=bar".
X#
X# If configuration varaible $getopt_compat is set to a non-zero value,
X# options that start with "+" may also include their arguments,
X# e.g. "+foo=bar".
X#
X# A return status of 0 (false) indicates that the function detected
X# one or more errors.
X#
X################ Some examples ################
X#
X# If option "one:i" (i.e. takes an optional integer argument), then
X# 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# In GNU or POSIX format, option names and values can be combined:
X#
X#    +foo=blech                -> $opt_foo = 'blech'
X#    --bar=            -> $opt_bar = ''
X#    --bar=--          -> $opt_bar = '--'
X#
X################ Configuration values ################
X#
X#   $autoabbrev      Allow option names to be abbreviated to uniqueness.
X#                    Default is 1 unless environment variable
X#                    POSIXLY_CORRECT has been set.
X#
X#   $getopt_compat   Allow '+' to start options.
X#                    Default is 1 unless environment variable
X#                    POSIXLY_CORRECT has been set.
X#
X#   $option_start    Regexp with option starters.
X#                    Default is (--|-) if environment variable
X#                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
X#
X#   $order           Whether non-options are allowed to be mixed with
X#                    options.
X#                    Default is $REQUIRE_ORDER if environment variable
X#                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
X#
X#   $ignorecase      Ignore case when matching options. Default is 1.
X#
X#   $debug           Enable debugging output. Default is 0.
X
X################ History ################
X#
X# 12-Feb-1994          Johan Vromans  
X#    Added "!" for negation.
X#    Released to the net.
X#
X# 26-Aug-1992          Johan Vromans  
X#    More POSIX/GNU compliance.
X#    Lone dash and double-dash are now independent of the option prefix
X#      that is used.
X#    Make errors in NGetOpt parameters fatal.
X#    Allow options to be mixed with arguments.
X#      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
X#    Allow --foo=bar and +foo=bar (but not -foo=bar).
X#    Allow options to be abbreviated to minimum needed for uniqueness.
X#      (Controlled by configuration variable $autoabbrev.)
X#    Allow alias names for options (e.g. "foo|bar=s").
X#    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
X#      translated to "_" to form valid perl identifiers
X#      (e.g. $opt_pcc_struct_return).
X#
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################ Configuration Section ################
X
X{   package newgetopt;
X
X    # Values for $order. See GNU getopt.c for details.
X    $REQUIRE_ORDER = 0;
X    $PERMUTE = 1;
X    $RETURN_IN_ORDER = 2;
X
X    # Handle POSIX compliancy.
X    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
X       $autoabbrev = 0;        # no automatic abbrev of options (???)
X       $getopt_compat = 0;     # disallow '+' to start options
X       $option_start = "(--|-)";
X       $order = $REQUIRE_ORDER;
X    }
X    else {
X       $autoabbrev = 1;        # automatic abbrev of options
X       $getopt_compat = 1;     # allow '+' to start options
X       $option_start = "(--|-|\\+)";
X       $order = $PERMUTE;
X    }
X
X    # Other configurable settings.
X    $debug = 0;                        # for debugging
X    $ignorecase = 1;           # ignore case when matching options
X    $argv_end = "--";                # don't change this!
X}
X
X################ Subroutines ################
X
Xsub NGetOpt {
X

X
X    package newgetopt;
X
X    local ($[) = 0;
X    local ($genprefix) = $option_start;
X    local ($argend) = $argv_end;
X    local ($error) = 0;
X    local ($opt, $optx, $arg, $type, $mand, %opctl);
X    local ($pkg) = (caller)[0];
X    local ($optarg);
X    local (%aliases);

X
X    print STDERR "NGetOpt 1.14 -- 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    }
X
X    # Verify correctness of optionlist.
X    %opctl = ();

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

X           die ("Error in option spec: \"", $opt, "\"\n");
X           $error++;
X           next;
X       }
X       local ($o, $c, $a) = ($1, $2);
X
X       if ( ! defined $o ) {
X           $opctl{''} = defined $c ? $c : '';
X       }
X       else {
X           # Handle alias names
X           foreach ( split (/\|/, $o)) {
X               if ( defined $c && $c eq '!' ) {
X                   $opctl{"no$_"} = $c;
X                   $c = '';
X               }
X               $opctl{$_} = defined $c ? $c : '';
X               if ( defined $a ) {
X                   # Note alias.
X                   $aliases{$_} = $a;
X               }
X               else {
X                   # Set primary name.
X                   $a = $_;
X               }
X           }
X       }
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

X       print STDERR ("=> option \"", $opt, "\"\n") if $debug;
X       $arg = undef;
X       $optarg = undef;
X       $array = 0;
X
X       #### Determine what we have ####
X
X       # Double dash is option list terminator.
X       if ( $opt eq $argend ) {

X           return ($error == 0);
X       }
X       elsif ( $opt =~ /^$genprefix/ ) {
X           # Looks like an option.
X           $opt = $';          # option name (w/o prefix)
X           # If it is a long opt, it may include the value.
X           if (($+ eq "--" || ($getopt_compat && $+ eq "+")) &&
X               $opt =~ /^([^=]+)=/ ) {
X               $opt = $1;
X               $optarg = $';
X               print STDERR ("=> option \"", $opt,
X                             "\", optarg = \"$optarg\"\n")
X                   if $debug;
X           }
X
X       }
X       # Not an option. Save it if we may permute...
X       elsif ( $order == $PERMUTE ) {

X           next;
X       }
X       # ...otherwise, terminate.
X       else {
X           # Push back and exit.

X           return ($error == 0);
X       }
X
X       #### Look it up ###
X
X       $opt =~ tr/A-Z/a-z/ if $ignorecase;
X
X       local ($tryopt) = $opt;
X       if ( $autoabbrev ) {

X
X           # Turn option name into pattern.
X           ($pat = $opt) =~ s/(\W)/\\\1/g;
X           # Look up in option names.



X               if $debug;
X
X           # Check for ambiguous results.

X               print STDERR ("Option ", $opt, " is ambiguous (",

X               $error++;
X               next;
X           }
X
X           # Complete the option name, if appropriate.

X               $tryopt = $hits[0];
X               print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
X                   if $debug;
X           }
X       }
X
X       unless  ( defined ( $type = $opctl{$tryopt} ) ) {
X           print STDERR ("Unknown option: ", $opt, "\n");
X           $error++;
X           next;
X       }
X       $opt = $tryopt;
X       print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
X
X       #### Determine argument status ####
X
X       # If it is an option w/o argument, we're almost finished with it.
X       if ( $type eq '' || $type eq '!' ) {
X           if ( defined $optarg ) {
X               print STDERR ("Option ", $opt, " does not take an argument\n");
X               $error++;
X           }
X           elsif ( $type eq '' ) {
X               $arg = 1;               # supply explicit value
X           }
X           else {
X               substr ($opt, 0, 2) = ''; # strip NO prefix
X               $arg = 0;               # supply explicit value
X           }
X           next;
X       }
X
X       # Get mandatory status and type info.

X
X       # Check if there is an option argument available.
X       if ( defined $optarg ? ($optarg eq '') : ($#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 the argument is valid for this option ####
X
X       if ( $type eq "s" ) { # string
X           # A mandatory string takes anything.
X           next if $mand eq "=";
X
X           # An optional string takes almost anything.
X           next if defined $optarg;
X           next if $arg eq "-";
X
X           # Check for option or option list terminator.
X           if ($arg eq $argend ||
X               $arg =~ /^$genprefix.+/) {
X               # Push back.

X               # Supply empty value.
X               $arg = '';
X           }
X           next;
X       }
X
X       if ( $type eq "n" || $type eq "i" ) { # numeric/integer
X           if ( $arg !~ /^-?[0-9]+$/ ) {
X               if ( defined $optarg || $mand eq "=" ) {
X                   print STDERR ("Value \"", $arg, "\" invalid for option ",
X                                 $opt, " (number expected)\n");
X                   $error++;
X                   undef $arg; # don't assign it
X               }
X               else {
X                   # Push back.

X                   # Supply default value.
X                   $arg = 0;
X               }
X           }
X           next;
X       }
X
X       if ( $type eq "f" ) { # fixed real number, int is also ok
X           if ( $arg !~ /^-?[0-9.]+$/ ) {
X               if ( defined $optarg || $mand eq "=" ) {
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               else {
X                   # Push back.

X                   # Supply default value.
X                   $arg = 0.0;
X               }
X           }
X           next;
X       }
X
X       die ("NGetOpt internal error (Can't happen)\n");
X    }
X
X    continue {
X       if ( defined $arg ) {
X           $opt = $aliases{$opt} if defined $aliases{$opt};
X           # Make sure a valid perl identifier results.
X           $opt =~ s/\W/_/g;
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    }
X    return ($error == 0);
X}
X
X################ Package return ################
X
X1;
X
X################ End of newgetopt.pl ################
SHAR_EOF
chmod 0444 newgetopt.pl ||
echo 'restore of newgetopt.pl failed'
Wc_c="`wc -c < 'newgetopt.pl'`"
test 15094 -eq "$Wc_c" ||
        echo 'newgetopt.pl: original size 15094, current size' "$Wc_c"
fi
exit 0
--
----------------- New address as of November 1, 1993 -------------------------

NLnet, the Internet in the Netherlands                   Phone: +31 20 5924245
Kruislaan 413, 1098 SJ Amsterdam, The Netherlands          Fax: +31 20 6655311



Thu, 01 Aug 1996 01:59:57 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. DBI object version 1.14 does not match $DBI::VERSION 1.18

2. Newgetopt.pl, version 1.13.

3. newgetopt.pl by Johan Vromans version 1.13

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