# $Header: /monk/rcs/parts/sccs/parseargs.pl,v 8.1.1.4 1992/05/09 00:46:10 muir Exp muir $

#############################################################################
#
#  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.
#
#	When parsing an @arg switch, argv's will be eaten until one that
#	begins with "-".  However, both "--FOO" and " -FOO" will be transformed
#	to "-FOO" and eaten...  Also, without $flags_first, "--" or "-" can be
# 	used to mark then end of a set of args.
#
# 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";

	print "ARGV=@ARGV\n" if $parseargs'debug;

	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;

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

		# '-' corrosponds to '--' because the first '-' was stripped.
		print "now on '$_' ... ($flags_first)\n" if $parseargs'debug;
		if ($flags_first && $_ eq '-') {
			push(@pos,@ARGV);
			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] =~ /^--./)) {
				print "ARGV[0] = '$ARGV[0]'\n" if $parseargs'debug;
				$ARGV[0] =~ s/^( |-)-(.*)$/-$1/; # "--FOO" -> "-FOO" && " -FOO" -> "-FOO"
				print "ARGV[0] = '$ARGV[0]' (after)\n" if $parseargs'debug;
				push(@pos,shift(@ARGV));
				$optional -= 1;
			};
			shift(@ARGV) if ($all && $ARGV[0] =~ /^-?-$/ && !$flags_first);
			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 "Dtype = '@type'\n";
		print "Dpositonal = '@positional'\n";
		print "Drequired: '@required'\n";
		print "Dpos: '@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;