Path: utzoo!attcan!uunet!crdgw1!rpi!julius.cs.uiuc.edu!apple!usc!snorkelwacker!bloom-beacon!eru!hagbard!sunic!mcsun!hp4nl!mhres!squirrel!jv
From: jv@mh.nl (Johan Vromans)
Newsgroups: comp.lang.perl
Subject: New getopt routine
Message-ID: <1990Sep19.080135.16052@squirrel.mh.nl>
Date: 19 Sep 90 08:01:35 GMT
Sender: jv@squirrel.mh.nl (Johan Vromans)
Reply-To: Johan Vromans <jv@mh.nl>
Distribution: comp
Organization: Multihouse Automation, the Netherlands
Lines: 236
X-Checksum-Snefru: dda13d77 afa3aca4 1e2c988c 995fc049

The following getopt-like routine handles program options in the style
of X11 and GNU: long option names, no bundling. Just like 'perl -s',
but it can handle arguments to options also.

Comments are welcome, but PLEASE: no flame wars about this type of
option handling. If you want to stick to 'foo -TfgrhpoitsoXaG' just do
so and ignore this posting.

Disclaimer: since program options are usually parsed once per
invocation, I prefer readability and maintainability over efficiency.

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is newgetopt, 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".
#
# made 09/19/1990 08:00 UTC by jv@mh.nl
# Source directory /u/jv
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   5281 -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' &&
# newgetopt.pl -- new options parsing
X
# SCCS Status     : @(#)@ newgetopt.pl	1.5
# Author          : Johan Vromans
# Created On      : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
# Last Modified On: Wed Sep 12 17:06:01 1990
# Update Count    : 28
# Status          : Okay
X
# 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.
# 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 = '--'
#
X
package newgetopt;
X
$debug = 0;			# for debugging
X
sub main'NGetOpt {
X    local (@optionlist) = @_;
X    local ($[) = 0;
X    local ($genprefix) = "-";
X    local ($error) = 0;
X    local ($opt, $optx, $arg, $type, $mand, @hits);
X
X    # See if the first element of the optionlist contains option
X    # starter characters.
X    $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
X
X    # Turn into regexp.
X    $genprefix =~ s/(\W)/\\\1/g;
X    $genprefix = "[" . $genprefix . "]";
X
X    # Verify correctness of optionlist.
X    @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
X    if ( $#hits >= 0 ) {
X	foreach $opt ( @hits ) {
X	    print STDERR ("Error in option spec: \"", $opt, "\"\n");
X	    $error++;
X	}
X	return 0;
X    }
X
X    # Process argument list
X
X    while ( $#main'ARGV >= 0 ) {		#'){
X
X	# >>> See also the continue block <<<
X
X	# Get next argument
X	$opt = shift (@main'ARGV);		#');
X	print STDERR ("=> option \"", $opt, "\"\n") if $debug;
X	$arg = undef;
X
X	# Check for exhausted list.
X	if ( $opt =~ /^$genprefix/o ) {
X	    # Double occurrence is terminator
X	    return ($error == 0) if $opt eq "$+$+";
X	    $opt = $';		# option name (w/o prefix)
X	}
X	else {
X	    # Apparently not an option - push back and exit.
X	    unshift (@main'ARGV, $opt);		#');
X	    return ($error == 0);
X	}
X
X	# Grep in option list. Hide regexp chars from option.
X	($optx = $opt) =~ s/(\W)/\\\1/g;
X	@hits = grep (/^$optx([=:].+)?$/, @optionlist);
X	if ( $#hits != 0 ) {
X	    print STDERR ("Unknown option: ", $opt, "\n");
X	    $error++;
X	    next;
X	}
X
X	# Determine argument status.
X	undef $type;
X	$type = $+ if $hits[0] =~ /[=:].+$/;
X	print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
X
X	# If it is an option w/o argument, we're almost finished with it.
X	next unless defined $type;
X
X	# Get mandatory status and type info.
X	($mand, $type) = $type =~ /^(.)(.)$/;
X
X	# Check if the argument list is exhausted.
X	if ( $#main'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	    next;
X	}
X
X	# Get (possibly optional) argument.
X	$arg = shift (@main'ARGV);		#');
X
X	# Check if it is a valid argument. A mandatory string takes
X 	# anything. 
X	if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
X
X	    # Check for option list terminator.
X	    if ( $arg eq "$+$+" ) {
X		# Complain if an argument is required.
X		if ($mand eq "=") {
X		    print STDERR ("Option ", $opt, " requires an argument\n");
X		    $error++;
X		}
X		# Push back so the outer loop will terminate.
X		unshift (@main'ARGV, $arg);	#');
X		next;
X	    }
X
X	    # Maybe the optional argument is the next option?
X	    if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
X		# Yep. Push back.
X		unshift (@main'ARGV, $arg);	#');
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, " (numeric required)\n");
X		$error++;
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 required)\n");
X		$error++;
X	    }
X	    next;
X	}
X
X	if ( $type eq "s" ) { # string
X	    next;
X	}
X
X    }
X    continue {
X	print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
X	eval ("\$main'opt_$opt = \$arg";);
X    }
X
X    return ($error == 0);
}
1;
SHAR_EOF
chmod 0444 newgetopt.pl ||
echo 'restore of newgetopt.pl failed'
Wc_c="`wc -c < 'newgetopt.pl'`"
test 5281 -eq "$Wc_c" ||
	echo 'newgetopt.pl: original size 5281, current size' "$Wc_c"
fi
exit 0
-- 
Johan Vromans				       jv@mh.nl via internet backbones
Multihouse Automatisering bv		       uucp: ..!{uunet,hp4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: +31 1820 62911/62500
------------------------ "Arms are made for hugging" -------------------------