From jt@lunatic.nambeInstitute.org Sun Apr 14 01:55:59 1996
Date: Sun, 14 Apr 1996 02:30:46 -0600
From: James Theiler <jt@lunatic.nambeInstitute.org>
To: jt@nis.lanl.gov

#! /packages/bin/perl
# $Id: opt.pl,v 1.1 1996/04/17 22:04:45 jt Exp $
# opt is a package for option parsing in a command line,
# from a parameter input file (*.opt) or with a rudimentary menu 
# For more information, skip ahead to the __END__

# Variable Naming Conventions
# all variables and function names begin with "opt..."
# except those that are reset by the user as prefixes
#
# $optUpperCase   variables are global flags: debug, test, etc.
# $optDoSomething are flags for turning on various options, Abbrev, Eval, etc
# &optUpperCase   are functions
# $opt__name      variables are global to opt
# $opt_name       variables are set by opt when User supplies name
#                 (note that the "opt_" prefix is resettable)
# TTY_IN, TTYOUT  are global file handles

require "flush.pl";

$optDebug = 0;
$optTest  = 0;
$optDoAbbrev = 1;            ## permit '-x' as synonym for '-xxx'
$optDoEvalExpressions = 1;   ## permit '#1+1' as synonym for '2'
$optInitialized = 0;         ## do not alter; this will be set to 1
                             ## when &optInitialize is called

### Global Variables:

$optTitle = "";
$optUsage = "";
$optRunFcn = "optNullFcn";
$optMenuPrompt = "\$opt_";
$optValPrefix = "opt_";
undef $optEnvPrefix;
%optAbbrev = ();
($opt__nmax,$opt__vmax,$opt__dmax)=(5,5,15);



@optNameList = ();
if ($optDoAbbrev) {
    require "abbrev.pl";
}

## Here is where to add a new attribute:

@optAttList  = ("Descript", "Help", "Default", "Type");

foreach $att (@optAttList) {
    ## initialize the associative arrays
    eval "%opt$att = ();";
    ## define subtoutines for optGetDescript, optGetHelp, etc.
    print "eval...",
    "sub optGet$att \{ \&optGet($att,\$_[0]) \}",
    "\n" if $optDebug;
    eval "sub optGet$att \{ \&optGet($att,\$_[0]); \}";
    eval "sub optSet$att \{ \&optSet($att,\$_[0],\$_[1]); \}";
}

sub optSetEnvPrefix {
    local($prefix)=@_;
    $prefix =~ tr/a-z/A-Z/;
    $optEnvPrefix = $prefix;
}

sub optSetUsage   {$optUsage = $_[0];}
sub optSetTitle   {$optTitle = $_[0];}

sub optShowUsage {
    ## should this really go to STDERR ?
    print STDERR $optTitle,"\n" if $optTitle;
    print STDERR "[$0] ",$optUsage,"\n";
    print STDERR "To invoke the menu, type:\n";
    print STDERR "     ",$0," \$ \n";
}

sub optFullName {
    local($name) = @_;
    if ($name eq "") {
	return $name;
    }
    local($fullname)=$optAbbrev{$name};
    if (! &optIsNameRegistered($fullname)) {
	warn "[$name -> $fullname] is not a registered opt name\n";
	$fullname = "";
    }				
    return $fullname;
}

sub optGet {
    local($attribute,$name) = @_;
    local($fullname)  = &optFullName($name);

    $fullname = $name unless $fullname;
    local($retvalue) = "";
    if ( grep($attribute,@optAttList) ) { 
	## make sure $attribute is one of the categories
	eval "\$retvalue = \$opt$attribute\{\"".$fullname."\"\}";
        print "oG: optDecript=",$optDescript{$fullname},"\n" if $optDebug;
        print "oG: retvalue=$retvalue\n" if $optDebug;
    }
    return $retvalue;
}
sub optSet {
    local($attribute,$name,$value) = @_;
    local($fullname)  = &optFullName($name);
    $fullname = $name unless $fullname;
    local($retvalue) = "";
    if ( grep($attribute,@optAttList) ) { 
	## make sure $attribute is one of the categories
	eval "\$opt$attribute\{\"".$fullname."\"\} = \"$value\"";
	## check to make sure it works
	$retvalue = &optGet($attribute,$name);
	if ( $retvalue ne $value) {
	    warn "optSet: error in setting att=$attribute,value=$value, getting $retvalue.";
	}
    } else {
	warn "[$name] is not a registered option name\n";
    }
    return $retvalue;
}

sub optNullFcn { print "...\n";}

sub optRegisterRun {
    local($fcn) = @_;
    $optRunFcn = $fcn;
}

sub optRegister {
    local($name,$def_value,$description,$help) = @_;
    if ($optIsInitialized) {
	die "Cannot call optRegister after optParse\n";
    }
    push(@optNameList, $name);
    if ($optDoAbbrev) {
	&abbrev(*optAbbrev,@optNameList); # update the abbrev table
    } else {
	$optAbbrev{$name}=$name;
    }
    &optSetDefault($name,"$def_value");
    &optSetValue($name,"$def_value");

    $description = $name unless $description;
    $description =~ s/\s*$//; # remove trailing whitespace
    &optSetDescript($name,"$description");
    &optSetHelp($name,"$help") if $help;
}
sub optIsNameRegistered {
    local($name) = @_;
    local($tname,$value);
    #print "oINR n=$name\n";
    foreach $tname ( @optNameList) { ## can we just grep ??
	return 1 if $name eq $tname;
    }
    return 0;
}
    

sub optGetValue { 
    local($value) = eval "\$$optValPrefix$_[0]";
#    print "valu=$value = eval...","\$$optValPrefix$_[0]","\n";
    $value;
}
sub optSetValue { 
    local($name,$value) = @_;
#    print "oSV: n=$name,v=$value,eval...","\$$optValPrefix$name = \"$value\"";
#    print "\n";
    if ($value eq "") {
	$value = &optGetDefault($name);
    } 
    if ($optDoEvalExpressions && substr($value,0,1) eq "#") {
	$value = substr($value,1+$[);
	$value = eval "$value";
    }
    eval "\$$optValPrefix$name = \"$value\"";
}


sub optGetValDescript {
    local($name) = @_;
    local($value,$descript);
    $value = &optGetValue($name);
    $descript = &optGetDescript($name);
    print "oGVD: val=$value, des=$descript\n" if $optDebug;
    ($value,$descript);
}


sub optShowOne {
    local($name) = @_;
    local($val,$descript);
    ## using this function caused a coredump, don't know why.
    ($val,$descript) = &optGetValDescript($name);
    print " " x ($opt__nmax-length($name));
    print "$name = $val";
    print " " x ($opt__vmax-length($val));
    print "     ;$descript";
    local($default) = &optGetDefault($name);
    if ($val ne $default) {
	print " " x ($opt__dmax-length($descript));
	print "  [",&optGetDefault($name),"]";
    } 
    print "\n";
}
sub optShowAll {
    local(*FILE) = @_;
    local($oldfh)=select(FILE); 
    foreach $name ( @optNameList ) {
	&optShowOne($name);
    }
    select($oldfh);
}
sub optCommandLine {
    local(@argv) = @_;
    local($name,$val);
    print STDERR "argv: ",join(' ',@argv),"\n";
    while (@argv) {
	$_ = shift @argv;
	print STDERR "\$_ = $_, argv=$argv[0]\n";
	last if /^--$/;
	if ( /^\?\?/ ) {
	    &optShowAll;
	} elsif ( ($name,$val) = /(\w+)\s*=\s*(\S.*)/ ) {
            local($fullname)=&optFullName($name);
	    &optSetDefault($fullname,$val);
	    &optSetValue($fullname,$val);
	} elsif ( ($name)=/^(\w+)=$/ ) {
            local($fullname)=&optFullName($name);
	    &optSetValue($fullname,&optGetDefault($fullname));
	} elsif ( ($name)=/^-(\w+)/ ) {
	    $val = shift @argv;
	    &optSetDefault($fullname,$val);
            local($fullname)=&optFullName($name);
	    &optSetValue($fullname,$val);
	} elsif (/\$/) {
	    &optMenu;
	} elsif (/^@@/) {
            &optReadFile("$0.opt");
	} elsif (/^@\s*(\S*)/) {
            &optReadFile("$1");
	} elsif (/^-$/) {
	    &optShowUsage;
	    exit 1;
	} elsif (/^--$/) {
	    &optShowUsage;
 	    print STDERR "The options are:\n";
	    &optShowAll(STDERR);
 	    exit 1;
	} else {
	    push(@tmpargv, $_);
	}
    }
    ## the problem is that tmpargv is not passed when the
    ## menu is invoked, a la 'testopt hello.world $'
    ## maybe this is a feature and not a bug?
    @tmpargv;
}
 
sub optMenu {
    ## but what if this gets invoked twice!?
    open(TTY_IN,  "/dev/tty") || die "cant open tty";
    open(TTYOUT,"> /dev/tty") || die "cant open tty";

    &optShowAll(TTYOUT);
    print TTYOUT "(Type ? for Help)\n";
    while(1) {
 	print TTYOUT "$optMenuPrompt";
 	&flush(TTYOUT);
 	chop($_ = scalar(<TTY_IN>)); ## inline editing would be nice!
 	if (/^\.$/) {
 	    exit;
	} elsif (/^\$$/) {
 	    last;
 	} elsif (/^$/) {
 	    &optShowAll(TTYOUT);
            print TTYOUT "(Type ? for Help)\n";
 	} elsif (/^\s*=\s*$/) {
 	    eval "&$optRunFcn";
 	} elsif (/^\s*\?\s*(\w+)/) {
 	    local($name) = $1;
 	    local($fullname)=&optFullName($name);
	    if ($fullname eq "") {
 		warn  "[$name] is not a registered opt name\n".
		    "Type just \'?\' for general help\n";
		next;
	    }
	    if ($name ne $fullname) {
		print "$name -> $fullname\n";
		$name = $fullname;
	    }
	    local($oldfh)=select(TTYOUT);
	    &optShowOne($fullname);
	    print TTYOUT " " x length($optMenuPrompt);
	    print TTYOUT &optGetHelp($fullname),"\n";
	} elsif (/^-?(\w+)=\s*$/ ) {
	    local($name)=$1;
            local($fullname)=&optFullName($name);
	    &optSetValue($fullname,&optGetDefault($fullname));
 	} elsif (/^-?(\w+)\s*==\s*(\S+)/) {
 	    local($name,$val)=($1,$2);
 	    local($fullname)=&optFullName($name);
	    &optSetDefault($fullname,$val);
	    &optSetValue($fullname,$val);
 	} elsif (/^-?(\w+)\s*=?\s*(\S+)/) {
 	    local($name,$val)=($1,$2);
 	    local($fullname)=&optFullName($name);
	    if ($name ne $fullname) {
		print "$name -> $fullname\n";
		$name = $fullname;
	    }
	    &optSetValue($fullname,$val);

 	} elsif (/^\s*\?\s*$/) {
	    &optGeneralHelp(TTYOUT);
 	} elsif (/^\s*\?\?\s*$/) {
	    print "verbose help:\n";
	    &optVerboseHelp(TTYOUT);
	} elsif (/^\!\s*(.*)/) {
	    print TTYOUT `$1`;
	} elsif (/^%%/) {
            &optWriteFile("$0.opt");
	} elsif (/^@@/) {
            &optReadFile("$0.opt");
	} elsif (/^%\s*(\S*)/) {
            &optWriteFile("$1");
	} elsif (/^@\s*(\S*)/) {
            &optReadFile("$1");
 	} else {
 	    warn "[$_]: invalid input line\n";
 	}
     }
 }

sub optWriteFile {
   local($file)=@_;
   if (-e $file) {
       rename("$file","$file~");
       print STDERR "options file [$file] has been overwritten\n";
       print STDERR "File [$file~] is backup file\n";
   }				
   open(OPTFILE,">$file") || die "cant open options file [$file]";
   &optShowAll(OPTFILE);
   &flush(OPTFILE);
   close(OPTFILE);
}

sub optReadFile {
   local($file)=@_;
   local($name,$val);
   open(OPTFILE,"$file") || die "cant open options file [$file]";
   while (<OPTFILE>) {
        ($name,$val)=/\s*(\w+)\s*=\s*(\S*)/;
	&optSetDefault($name,$val);
	&optSetValue($name,$val);
   }
   close(OPTFILE);
}

sub optParse {
    local(@argv)=@_;
    &optInitialize;
    @argv = &optCommandLine(@argv);
    @argv;
}
sub optInitialize {
    ## this routine is to be run AFTER all the optRegister calls
    $optIsInitialized=1;

    ## work out how long the various strings are, this is so that
    ## the menu can be more nicely formatted
    local($name,$val,$descript) ;
    local($len);
    foreach $name ( @optNameList ) {
	($val,$descript) = &optGetValDescript($name);
	$opt__nmax = $len if (($len = length($name)) > $opt__nmax);
	$opt__vmax = $len if (($len = length($val)) > $opt__vmax);
	$opt__dmax = $len if (($len = length($descript)) > $opt__dmax);
    }

    ## reset the defaults if there are any environment
    ## variables (and if user has defined $optEnvPrefix)
    if (defined($optEnvPrefix)) {
	foreach $name (@optNameList) {
	    local($envname) = $optEnvPrefix . $name;
	    $envname =~ tr/a-z/A-Z/;
	    local($enval) = $ENV{$envname};
	    if ( $enval ) {
		&optSetDefault($name,$enval);
		&optSetValue($name,$enval);
	    }
	}
    }
}

sub optVerboseHelp {
    local(*FILE)=@_;
    while (<DATA>) {
	print FILE;
    }
}
sub optGeneralHelp {
    local(*FILE)=@_;
    local($oldfh)=select(FILE);

    print "Type:\n";
    print " ?            ;for this message\n";
    print " ??           ;for a very long description of opt package\n";
    print " ?var         ;for info on a single variable\n";
    print " =            ;to run the registered Run function\n";
    print " .            ;to quit\n";
    print " !            ;execute shell command\n";
    print " @@           ;get options from file [$0.opt]\n";
    print " @<file>      ;get options from file\n";
    print " %%           ;put options in file [$0.opt]\n";
    print " %<file>      ;put options in file\n";
    print " var = value  ;to set a variable equal to a value\n";
    print " -var value   ;There Is More Than One Way To Do It\n";
    print " var value    ;ditto\n";
    print " v = value    ;can abbreviate variable names\n"
	if $optDoAbbrev;
    print " var = #expr  ;evaluates an expression, eg '#1+1' for '2'\n"
	if $optDoEvalExpressions;
    print " var == value ;sets value AND the default value of var\n";
}

if ($optTest) {
    #####################################################################
    ## Here is what a 'main' might look like:
    ##    
    #!/usr/bin/perl
    #require "opt.pl";
    &optRegister("xxx",3,"whatever xxx means");
    &optSetHelp("xxx","did you really expect help on xxx?");
    &optRegister("y",12.5,"describe y");
    &optRegister("zip",0);				
    &optRegister("Infile","\0","input file");
    &optRegisterRun("testRun");
    &optSetTitle("menu title message");
    &optSetUsage("usage message");
    &optParse(@ARGV);

    &testRun;
    sub testRun {

        $z= &optGetValue("xxx") + &optGetValue("y");
        print "xxx+y=",&optGetValue("xxx"),"+",&optGetValue("y"),"=$z\n";
        $z = &optGetValue("xxx");
        print "z=optGetValue(xxx) = ",$z."\n";
        printf "xxx = %f\n",&optGetValue("xxx");
        
        print "xxx+y= $xxx+$y = ",$xxx+$y,"\n";
	print "infile=",$Infile,"\n";
	print "infile2=",&optGetValue("Infile"),"\n";
	$xxx=17;
        printf "xxx = %f\n",$xxx;
	$y = &optGetValue("xxx");
        print "y=optGetValue(xxx) = ",$y."\n";
    }
}

1; ## so that 'require "opt.pl"' will return 1

__END__
Can you read these lines using <DATA> ?

$Log: opt.pl,v $
Revision 1.1  1996/04/17 22:04:45  jt
extensions to C-opt

% Revision 1.1  1995/03/30  22:10:14  jt
% Initial revision
%
% Revision 1.8  1994/10/03  22:20:07  jt
% these changes were made during my stay at the OmniInnerHarborHotel
% in Baltimore during the ADASS conference (when i should have been
% reading all the literature on FITS file formats!)  quite a number
% of new bells and whistles, including:
%   eval expressions: '-x #2+2' has same effect as '-x 4'
%   optValPrefix specifies the name of variable that is set; default
%      is "opt_" so that -xxx 5 changes value of $opt_xxx
%   optSetEnvPrefix permits environment variables to be read for
%      defaults, eg  'setenv OPT_XXX 12' makes 12 new default for -xxx
%   distinguishes values and defaults, so that (on menu prompt say)
%      'xxx=' sets xxx back to default, 'xxx==7' resets default to 7
%   at least attempts to pass ARGV on to main program sans the arguments
%      that have been parsed by the opt.pl package
%   uses 'optParse' instead of 'optInitialize' to get things started.
%
% Revision 1.7  1994/09/25  11:23  dp
% added support for optTitle and optUsage like c-opt, and support
% for the "-" and "--" usage command line options.
% changed parsing in @ file from ($name,$val)=/\s*(\w+)\s=\s(.*)\s*;/;
% to ($name,$val)=/\s*(\w+)\s=\s(\S*)\s*;/; to get rid of excess 
% whitespace.
%
% Revision 1.6  1994/09/24  12:08:32  jt
% this is dp's version, with many fixes and enhancements to my 1.4
% including @file, @@, %file, %%, etc.  also keep an eye on how
% and when the $xxx variable is set compared to $optValue("xxx").
%
% Revision 1.6  1994/09/23  18:50  dp
% added some really simple support for @@, @file, %%, and %file. Format is
% different from c-opt which is certainly a drawback
%
% Revision 1.5  1994/09/23  16:46  dp
% changed optSetValue() to call optSetVal(). changed optGetVal() to 
% actually reset the variable (not sure if i like this or not). added the 
% ! option to the menu, added opt{Set,Get}Help() and made it so ?var will
% print out whatever was set by optSetHelp(). added "abbrev" for the 
% command line, and (Type ? for Help) at the bottom of menu like c-opt.
%
% Revision 1.4  1994/09/23  16:53:05  jt
% mildly cleaned up version that does still sort of work. there is still
% a problem distinguishing the empty string from "", but i don't know if
% this points to a more serious problem or not.  this version also includes
% dp's fix of putting $value in quotes like \"$value\" in optSetVal.
%