emacs/mps/qa/test/script/optproc

#!/usr/local/perl -w
#
# subroutines for processing options to qa commands
# Each command can specify which options it requires,
# and what, if anything, they default to.
# In no default is specified, global defaults will be
# used, and if no global default is given, we'll get
# an error message.

1;

require "options";

sub options {
 local (@req) = @_;

 &parseoptions;
 &applydefaults;
 &requiredoptions(@req);
}

sub requiredoptions {
 local ($pur, $missing, $report, $qa_opt) = ("", 0, "");
 local (@missopt);

 foreach (@_) {
  unless (&getoption($_)) {
   $missing = $missing + 1;
   push(@missopt, $_);
  }
 }
 if ($missing > 0) {
  if ($missing > 1) {
   $pur = "s";
  }
  print "Error: $qa_command requires the following option".
   $pur.":\n";
  &explainoptions(@missopt);
  die "\n";
 }
}

sub parseoptions {
 local ($tem);

 while ($_ = shift(@ARGV)) {
  if (/^\-+(.*)$/i) { # allow >1 minus sign before options!
   if ($qa_options{$1}) {
    $qa_opt_val = shift(@ARGV);
    &setoption($qa_options{$1}, $qa_opt_val);
   } else {
    if ($1 =~ /^no/) { # prefix "no" negates any flag
     $flag = $1;
     $flag =~ s/^no//;
     $qa_opt_val = "off";
    } else {
     $qa_opt_val = "on";
     $flag = $1;
    }
    unless ($qa_flags{$flag}) {
     die "Unrecognized option or flag: $1.\n";
    }
    &setoption($qa_flags{$flag}, $qa_opt_val);
   }
  } else {
   push(@qa_args, $_);
  }
 }
}

sub getoption {
 local ($opt) = @_;
 return eval "\$".$opt;
}

sub setoption {
 local ($opt, $val) = @_;
 if ($val) {
  eval "\$".$opt." = \$val";
 }
}

sub flagcode {
 local ($opt, $code) = @_;
 foreach $code (keys %qa_flags) {
  if ($qa_flags{$code} eq $opt) {
   return $code
  }
 }
 return 0;
}

sub optioncode {
 local ($opt, $code) = @_;
 foreach $code (keys %qa_options) {
  if ($qa_options{$code} eq $opt) {
   return $code
  }
 }
 return 0;
}

sub applydefaults {
 local ($opt, $val, %arr);

 %arr = (%qa_options, %qa_flags);

 foreach (keys %arr) {
  $opt = ($qa_options{$_} || $qa_flags{$_});
  unless (&getoption($opt)) {
   $val = $ENV{"MMQA_".$opt};
   unless ($val) {
    $val = $qa_defaults{$opt};
   }
   &setoption($opt, $val);
  }
 }
}

sub explainoptions {
 local @keys = @_;
 local ($optname, $optcode, $optcur);

 $~ = "OPTLIST";

 print "\n";
 $optname = "OPTION";
 $optcode = "CODE";
 $optcur  = "CURRENT";
 write;
 print "\n";

 foreach $key (@keys) {
  $optname = "MMQA_$key";
  if (&optioncode($key)) {
   $optcode = "-".&optioncode($key)." <value>";
  } elsif (&flagcode($key)) {
   $optcode = "-[no]".&flagcode($key);
  } else {
   $optcode = "";
  }
  $optcur = (&getoption($key) || "");
 write;
 }
}

sub displayalloptions {
 &explainoptions(values %qa_options, values %qa_flags);
}

format OPTLIST =
 @<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$optname, $optcode, $optcur
.