#
# AFS-style command line parsing
#
# by bert Dvornik <bert@mit.edu>, Watchmaker Zone Night Patrol
#
# $Id: agetopt.pl,v 1.2 1996/04/19 17:58:43 bert Exp $

unshift(@RCSID, '$Id: agetopt.pl,v 1.2 1996/04/19 17:58:43 bert Exp $');

package agetopt;

$debug = 0;			# debugging level
$delim = "\000";		# delimiter for embedding stuff in strings
$valid_positional = "^[^-]";	# regexp for deciding if a positional arg is ok

%explicit = ();			# information on explicit options
%implicit = ();			# information on substring options
%ambiguous = ();		# set if multiple substring options overlap

@options = ();			# list of arg-taking opts in positional order
%nargs = ();			# number of args for each option


sub main'agetopt {	# ("-opt1", "-opt2:", ...)
    local(@optdesc);
    for $_ (@_) {
	/^([^:]*)(:*)$/ || warn "Invalid agetopt syntax: `$_'\n";
	&parse_optpair($1, length($2));
    }

    &agetopt_optdesc();
}

sub agetopt_optdesc {	# ("-opt1", nargs1, "-opt2", nargs2, ...)
    if (@_) {
	&parse_optdesc(@_);
    }
    &dump_rules if ($debug>1);

    &extract_options(@ARGV);
}

sub parse_optdesc {	# ("-opt1", nargs1, "-opt2", nargs2, ...)
    local(@optdesc) = @_;
    local($opts, $num);

    warn "Multiple calls to agetopt'parse_optdesc!\ncontinuing" if $parsed;
    $parsed++;

    while(@optdesc) {
	$opts = shift(@optdesc);
	$num = shift(@optdesc);

	&parse_optpair($opts, $num);
    }
}

sub parse_optpair {	# ("-option", nargs)
    local($opts, $num) = @_;
    local(@opts, $opt, $i);

    @opts = split(/$delim/, $opts);

    # Add $opts[0] to the positional list of options, record number of args.
    # (If an option starts with $delim, it means "not positional".)
    if ($opts[0]) {
	push (@options, $opts[0]) if $num;
    } else {
	shift(@opts);
    }
    $nargs{$opts[0]} = $num;

    for $opt (@opts) {
	# label $opt as an explicit option.
	&make_explicit($opt, $opts[0]);

	# label substrings of $opt as implicit option.
      SUBSTRING:
	for ($i=length($opt)-1; $i>0; $i--) {
#	    printf ">>> %-10s %3d %3d\n", substr($opt,0,$i), $i, $num;
	    (&make_implicit(substr($opt,0,$i), $opts[0]))|| last SUBSTRING;
	}
    }
}

sub make_explicit {	# ("-option", value)
    local($opt, $val) = @_;

    if ($explicit{$opt}) {
	die "Option `$opt' has been defined more than once.\naborting";
    }
    if ($implicit{$opt}) {
	print STDERR "Warning: option `$opt' could be confused with `",
	    $implicit{$opt}, "'.\n"  if $debug;
    }
    $explicit{$opt} = $val;
    1;
}

sub make_implicit {	# ("-option", value)
    local($opt, $val) = @_;

    if ($explicit{$opt}) {
	# explicit options supersede implicit ones, so we should do
	# nothing and return 0 to exit the loop here.
	print STDERR "Warning: option `$opt' may be confused with `$val'.\n"
	    if $debug;
	0;
    } elsif ($implicit{$opt}) {
	# a conflict means that an option is ambiguous.
	# stay in the loop so that all substrings get tagged as ambiguous.
	$ambiguous{$opt}++;
	1;
    } else {
	$implicit{$opt} = $val;
	1;
    }
}

sub extract_options {	# (@ARGV)
    local(@argv) = @_;
    local($arg, $opt, $i, @arglist);
    local(%value);

    while (@argv) {
	$arg = shift(@argv);

	if ($ambiguous{$arg}) {
	    return "Ambiguous switch `$arg'";
	}

	$opt = ($explicit{$arg} || $implicit{$arg});

	if ($opt) {
	    # if the current argument is an option flag, deal with it.

	    if ($nargs{$opt}) {
		# if the option takes arg(s), make sure there's no conflict...
		if ($value{$opt}) {
		    return "Value for `$opt' is given more than once";
		}
		# ...extract the args...
		@arglist=();
		for ($i=$nargs{$opt}; $i>0; $i--) {
		    return "The field `$opt' isn't completed properly"
			unless @argv;
		    push(@arglist, shift(@argv));
		}
		# ...and set the value to their agglomeration.
		$value{$opt} = join($delim, @arglist);
	    } else {
		# if the option takes no arguments, increment its value.
		$value{$opt}++;
	    }
	} else {
	    # if the argument is not an option flag, treat it as positional.

	    return "Argument `$arg' is not a valid positional"
		if (($valid_positional && ($arg !~ /$valid_positional/)));

	    # ignore all positional arguments whose values we already know.
	    while (@options && $value{$options[0]}) {
		shift(@options);
	    }

	    # check if they're all used up...
	    return "Too many positional arguments, can't place `$arg'"
		unless @options;

	    # ...then extract the remaining args, if any...
	    @arglist=($arg);
	    for ($i=($nargs{$options[0]}-1); $i>0; $i--) {
		return "The fields `$options[0]' aren't completed properly"
		    unless @argv;
		push(@arglist, shift(@argv));
	    }
	    # ...and set the value to their agglomeration.
	    $value{$options[0]} = join($delim, @arglist);
	}
    }
    %main'aopt = %value;
    "";
}

sub dump_rules {
    print ">> EXPLICIT:\n";
    for $k (sort keys %explicit) {
	printf ">> %-20s -> `%s'\n", "`$k'", $explicit{$k};
    }
    print ">> AMBIGUOUS:\n";
    for $k (sort keys %ambiguous) {
	printf ">> %-20s -> `%s'\n", "`$k'", $ambiguous{$k} 
	    unless ($explicit{$k});
    }
    print ">> IMPLICIT:\n";
    for $k (sort keys %implicit) {
	printf ">> %-20s -> `%s'\n", "`$k'", $implicit{$k}
	    unless ($explicit{$k} || $ambiguous{$k});
    }
}


1;
