From: muir@csi.com (David Muir Sharnoff)
Subject: Re: Question on how to use getopts.pl
Supersedes: <1992Apr10.232819.1575@csi.com>
Reply-To: muir@csi.com (David Muir Sharnoff)
Organization: Comdisco Systems Inc., Foster City, CA
Date: Fri, 10 Apr 1992 23:59:32 GMT

In article <1992Apr10.152847.25287@news.eng.convex.com> tchrist@convex.COM (Tom Christiansen) writes:
>Here's an article I posted a few months ago exhaustively detailing
>appraoches various and sundry to argument parsing.

I wrote a argument parsing package that's used in the RCS front
end here at Comdisco.  It only deals with multiple-character
switches.  

You specifiy how to parse the switches with a simple syntax that
gets transformed into a help message.

-Dave

-------------- begin "integrate -help" output ----------

Usage: integrate [options] baseline [<parts>]

Options:
   -user <user>                  Integrate just the specified users' parts
   -path leadpath                Set current location from top of tree
   -version version              Integrate at a particular version 
   -anystate                     Allow parts that are not marked 'Exp'
   -edit [editor] [<edit_flags>] Edit list of parts before integrating
   -help                         This message

Option abbreviations/aliases:
   -e                            Same as -edit
   -p                            Same as -path
   -revision                     Same as -version
   -u                            Same as -user
   -v                            Same as -version

Pupose:
   Integrate copies checked in parts to the master baselines.


------------  begin integrate ---------
#!/usr/local/bin/perl

$args = <<'END';
-u,user @user			Integrate just the specified users' parts
-p,path $leadpath		Set current location from top of tree
-v,revision,version $version	Integrate at a particular version 
-anystate			Allow parts that are not marked 'Exp'
-e,edit ?$editor ?@edit_flags	Edit list of parts before integrating
-help				This message
$baseline
?@parts
END

$help = <<'END';
Pupose:
   Integrate copies checked in parts to the master baselines.

END

require "parseargs.pl";
($synopsis,@help) = &parseargs($args,0);

if ($opt_help) {
	print @help;
	print $help;
	exit(0);
}

-------------- begin parseargs.pl ----------

# parseargs.pl
# David Muir Sharnoff
# muir@csi.com

#############################################################################
#
#  Copyright (c) 1992 Comdisco Systems Inc.
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#  3. All advertising materials mentioning features or use of this software
#     must display the following acknowledgement:
#       This product includes software developed by the Comdisco Systems Inc.
#  4. The name of Comdisco may not be used to endorse or promote products
#     derived from this software without specific prior written permission.
#
#  THIS SOFTWARE IS PROVIDED BY THE COMDISCO SYSTEMS INC ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL COMDISCO SYSTEMS INC BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
# This copyright notice derrived from material copyrighted by the Regents
# of the University of California.
#
#############################################################################

#
# naming covnentions, not that I use them:
#
#	-switch
#	-switch argument
#	-switch [optional_argument]
#	positional_argument
#
# Switches and arguments are collectively know as 'options'.
# 
# Arguments:
#
#	&parseargs($template,$flags_first)
#	
#	$template is a multi-line string that specifies what the switches
#	are.   In its normal mode of operation, all command line arguments
#	are examined to see if they are switches.  If $flags_first is set,
#	then parsing the command line for switches will stop at the first
#	argument that is not a switch ("--" is also recognized)
#
# the $template syntax recognized is:
#
#	-alias,alias,switch $arg ?$optional_arg @array_arg ?@optional_array_arg	<TAB> help message
#	$positional_arg
#	?$optional_positional_arg
#	@positional_arg_array
#	?@optional_positional_arg_array
#
# Return values:
#
#	Most of the information returned is in the form of global varialbes
# 	set.  In addition, a string $synopsis and an array @help are returned.
#
# 	the varialbles set are:
#
#	-switch			-- $opt_switch
#	-switch $arg		-- $opt_arg
#	-switch ?$arg		-- $opt_arg and $parse_switch
#	-switch @arg		-- @opt_arg
#	-switch ?@arg		-- @opt_arg and $parse_switch
#	$pos			-- $arg_pos
#	?$pos			-- $arg_pos
#	@pos			-- @arg_pos
#	?@pos			-- @arg_pos
#
#
# Additional features:
#
#	specify -SWITCH, user types: -noSWITCH, action: $opt_SWITCH = 0
#
#	switchs may take multiple arguments
#
#	if the description (help message) is "*hidden*" then the switch will not be listed
#	in the help or synopsis
#
#	The -help flag is treated specially.  If it is present, no errors will be flagged.
#
# Note:
#	
#	&parsargs operates on and modifies @ARGV.
#

sub parseargs
{
	local($template,$flags_first) = @_;
	local($synopsis,@helpinfo);
	local(@template) = split('\n',$template);
	local(@help,@help2);
	local(%flag,%valued);
	local(@positional,@type,@pos,@required);
	local(%same,%emas);
	local($ex);
	local($h,$h2);
	local($syn);
	local(@e);
	local($help);
	local($V,$W);
	local($done_already);
	local($ss,$sh);
	local(%oc)  = ( '?', '{' );
	local(%cc)  = ( '?', '}' );
	local(%ob)  = ( '?', '[' );
	local(%cb)  = ( '?', ']' );
	local(%ltc) = ( '@', '<' );
	local(%gtc) = ( '@', '>' );
	local($hidden);

	$synopsis = "Usage: $0";

	for $t (@template) {
		$t =~ s/^([^\t]*)[\t]+(.*)/$1/;
		push(@help2,$2);
		$hidden = ($2 eq '*hidden*');

		if ($t =~ /^-(\S+)$/) {
			for $f (split(',',$1)) {
				$flag{$f} = 1;
				$same{$f} = $1;
				$emas{$1} = $f;
				$ex = $f;
				print "flag $f ($1)\n" if $parseargs'debug;
			}
			$synopsis .= " [-$ex]" unless $hidden;
			push(@help,$ex);
			next;
		} elsif ($t =~ /^-(\S+)\s+((\?)?[@\$].+)$/) {
			for $f (split(',',$1)) {
				$valued{$f} = $2;
				print "V {$f} = $2\n" if $parseargs'debug;
				$same{$f} = $1;
				$emas{$1} = $f;
				$ex = $f;
			}
			print "option $ex ($1)" if $parseargs'debug;
			$ss = ""; $sh = "";
			for $f (split(' ',$2)) {
				$f =~ /^(\?)?([@\$])(.+)$/
					|| die "bad arg specifier: $f";
				$ss .= " $oc{$1}$ltc{$2}$3$gtc{$2}$cc{$1}";
				$sh .= " $ob{$1}$ltc{$2}$3$gtc{$2}$cb{$1}";
				print $ss if $parseargs'debug;
			}
			print "\n" if $parseargs'debug;
			$synopsis .= " [-$ex$ss]" unless $hidden;
			push(@help,"$ex$sh");
			next;
		} elsif ($t =~ /^(\?)?([\$@])(\S+)$/) {
			push(@positional,$3);
			push(@type,$2);
			push(@help,'');
			push(@required,$1);
			$synopsis .= " $oc{$1}$ltc{$2}$3$gtc{$2}$cc{$1}"
				unless $hidden;
		} else {
			die "could not parse arg specifier: '$t'";
		}
	}

	print "type = '@type'\n" if $parseargs'debug;
	print "positonal = '@positional'\n" if $parseargs'debug;

	while (@ARGV) {
		$_ = shift(@ARGV);
		print "working on $_...\n" if $parseargs'debug;

		unless (s/^-//) {
			push(@pos,$_);
			if ($flags_first) {
				push(@pos,@ARGV);
				last;
			} else {
				print "positional...\n" if $parseargs'debug;
				next;
			}
		}

		if ($flags_first && $_ eq '--') {
			last;
		}

		if (defined($flag{$_})) {
			print "matched flag $_ ($same{$_})\n" 
				if $parseargs'debug;
			push(@e,"\$opt_$emas{$same{$_}} = 1");
			$help = 1 if $emas{$same{$_}} eq "help";
			next;
		}
		if (/^(no|un)(.*)$/ && defined($flag{$2})) {
			print "UNmatched flag $2 ($same{$2})\n" 
				if $parseargs'debug;
			push(@e,"\$opt_$emas{$same{$2}} = 0");
			$help = 0 if $emas{$same{$2}} eq "help";
			next;
		}
		if (defined($valued{$_})) {
			print "matched arg $valued{$_}\n"
				if $parseargs'debug;
			local(@pos,@positional,@type,@required);
			local($all,$manditory,$optional);
			for $t (split(' ',$valued{$_})) {
				if ($t =~ /^(\?)?([\$@])(\S+)$/) {
					push(@positional,$3);
					push(@type,$2);
					push(@required,$1);
					$manditory++ if !$1 && $2 eq '$';
					$optional++ if $1 && $2 eq '$';
					$all = 1 if $2 eq '@'; 
					print "positional = @positional, type = @type, required = @required, m=$manditory, a=$all\n" if $parseargs'debug;
				} else {
					die "bad specifier: $t";
				}
			}
			print "positional = @positional, type = @type, required = @required, m=$manditory, a=$all\n" if $parseargs'debug;
			print "pos/argv = @pos %%% @ARGV\n" if $parseargs'debug;
			splice(@pos,0,0,splice(@ARGV,0,$manditory));
			while (($all || $optional > 0) 
					&& $ARGV[0] && $ARGV[0] !~ /^-/) {
				$ARGV[0] =~ s/^( |-)-(.*)$/-$1/;
				push(@pos,shift(@ARGV));
				$optional -= 1;
			};
			shift(@ARGV) if $all && $ARGV[0] =~ /^-?-$/;
			print "pos/argv = @pos %%% @ARGV\n" 
				if $parseargs'debug;
			push(@e,"\$parse_$emas{$same{$_}} = '-$_ @pos'");
			&parseargs'positional('opt',*pos,*positional
				,*type,*required,*e,$synopsis);
			next;
		}
		die "Illegal option: '-$_'\n$synopsis\n";
	}
	if ($parseargs'debug) {
		print "type = '@type'\n";
		print "positonal = '@positional'\n";
		print "required: '@required'\n";
		print "pos: '@pos'\n";
	}

	&parseargs'positional('arg',*pos,*positional,*type,*required,*e,$synopsis);

	#
	# reduce all the options lines down to one '[options]' for the
	# help info page
	#
	$syn = $synopsis;
	while ($syn =~ s/(\[[^\[\]]*\])\s+\[[^\[\]]*\]/$1/) {;}
	unless ($syn =~ s/^([^\[\]]*\[)[^\[\]]*(\][^\[\]]*)$/$1options$2/) {
		$syn = $synopsis;
	}
	$syn =~ tr/\{\}/\[\]/;
	$synopsis =~ tr/\{\}/\[\]/;

	@helpinfo = ( "\n", "$syn\n", "\n", "Options:\n" );
	while(@help) {
		$h = shift(@help);
		$h2 = shift(@help2);
		next if $h2 eq '*hidden*';
		if ($h =~ /^\S.*$/) {
			push(@helpinfo, "   -$h ".(" " x (25-length($h))).$h2."\n");
		} 
	}

	for $s (sort keys(%same)) {
		next if $s eq $emas{$same{$s}};
		push(@helpinfo,"\n","Option abbreviations/aliases:\n")
			unless $done_already;
		push(@helpinfo, 	"   -$s ".(" " x (25-length($s)))."Same as -$emas{$same{$s}}\n");
		$done_already = 1;
	}
	push(@helpinfo,"\n");

	for $e (@e) {
		$e .= ";\n";
		$e = &fixquoting($e,"'");
	}

	print "Eval:\n @e\n" if $parseargs'debug;
	eval "@e";
	die "Eval:\n @e: $@" if $@;
	return ($synopsis,@helpinfo);
}

sub parseargs'positional
{
	local($prefix,*pos,*positional,*type,*required,*e,$synopsis) = @_;
	local($V,$W);

	while ($type[0] eq '$' && @pos) {
		shift(@required);
		$V = shift(@positional);
		$W = shift(@pos);
		push(@e,"\$${prefix}_$V = '$W'");
		shift(@type);
	}
	while ($type[$#type] eq '$' && @pos) {
		shift(@required);
		$V = pop(@positional);
		$W = pop(@pos);
		push(@e,"\$${prefix}_$V = '$W'");
		pop(@type);
	}
	if ($type[0] eq '@' && @pos) {
		shift(@required);
		$V = shift(@positional);
		shift(@type);
		while(@pos) {
			$W = shift(@pos);
			push(@e,"push(\@${prefix}_$V,'$W')");
		}
	}
	while ($required[0] eq '?') {
		shift(@required);
		shift(@type);
		shift(@positional);
	}
	if ($parseargs'debug) {
		print "type = '@type'\n";
		print "positonal = '@positional'\n";
		print "required: '@required'\n";
		print "pos: '@pos'\n";
	}
	if (@positional && !$help) {
		die "not enough arguments: no '$positional[0]'\n$synopsis\n";
	}
	if (@pos && !$help) {
		die "too many aguments: '$pos[0]' not needed\n$synopsis\n";
	}
}

sub fixquoting
{
	local($cmd,$qq) = @_;
	local(@a) = split($qq,$cmd.$qq);
	return $cmd unless $#a > 2;
	return join($qq,$a[0],join("\\$qq",@a[1..($#a-1)]),$a[$#a]);
}

1;
From:muir@csi.com.UUCP (David Muir Sharnoff)
Newsgroups: comp.lang.perl
Subject: cmsg cancel <1992Apr10.232819.1575@csi.com>
Distribution: 
Organization: Comdisco Systems Inc., Foster City, CA
Newsgroups: comp.lang.perl