tchrist@convex.COM (Tom Christiansen) (05/21/91)
From the keyboard of tnelson@bubba.ma30.bull.com: : :I'd like for my script to accept multiple-character switches. GNU has :a getopt that will process long switches; has anyone done the :corresponding stuff in a new Perl getopt library? : :Any other suggestions on the best way to do this would be very much :appreciated! You might check and see whether perl's -s flag does what you want. (But you'll no longer be able to use a lone "-" to mean stdin.) --tom -- Tom Christiansen tchrist@convex.com convex!tchrist "So much mail, so little time."
jv@mh.nl (Johan Vromans) (05/21/91)
> I'd like for my script to accept multiple-character switches. GNU has > a getopt that will process long switches; has anyone done the > corresponding stuff in a new Perl getopt library? Reposting time... #!/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". # # made 05/21/1991 09:29 UTC by jv@largo # Source directory /nfs/squirrel/work/PD/X/xdtm # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 5697 -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# SCCS Status : @(#)@ newgetopt.pl 1.7 X# Author : Johan Vromans X# Created On : Tue Sep 11 15:00:12 1990 X# Last Modified By: Johan Vromans X# Last Modified On: Sun Oct 14 14:35:36 1990 X# Update Count : 34 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# 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 "-". 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 X# HISTORY X# 20-Sep-1990 Johan Vromans X# Set options w/o argument to 1. X# Correct the dreadful semicolon/require bug. X X Xpackage newgetopt; X X$debug = 0; # for debugging X Xsub 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 if ( ! defined $type ) { X $arg = 1; # supply explicit value X next; X } 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 $arg = ""; # don't assign it 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 $arg = ""; # don't assign it 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); X} X1; SHAR_EOF chmod 0444 newgetopt.pl || echo 'restore of newgetopt.pl failed' Wc_c="`wc -c < 'newgetopt.pl'`" test 5697 -eq "$Wc_c" || echo 'newgetopt.pl: original size 5697, 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" -------------------------