home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl502b.zip / lib / newgetopt.pl < prev    next >
Text File  |  1994-10-18  |  8KB  |  272 lines
  1. # newgetopt.pl -- new options parsing
  2.  
  3. # SCCS Status     : @(#)@ newgetopt.pl    1.13
  4. # Author          : Johan Vromans
  5. # Created On      : Tue Sep 11 15:00:12 1990
  6. # Last Modified By: Johan Vromans
  7. # Last Modified On: Tue Jun  2 11:24:03 1992
  8. # Update Count    : 75
  9. # Status          : Okay
  10.  
  11. # This package implements a new getopt function. This function adheres
  12. # to the new syntax (long option names, no bundling).
  13. #
  14. # Arguments to the function are:
  15. #
  16. #  - a list of possible options. These should designate valid perl
  17. #    identifiers, optionally followed by an argument specifier ("="
  18. #    for mandatory arguments or ":" for optional arguments) and an
  19. #    argument type specifier: "n" or "i" for integer numbers, "f" for
  20. #    real (fix) numbers or "s" for strings.
  21. #    If an "@" sign is appended, the option is treated as an array.
  22. #    Value(s) are not set, but pushed.
  23. #
  24. #  - if the first option of the list consists of non-alphanumeric
  25. #    characters only, it is interpreted as a generic option starter.
  26. #    Everything starting with one of the characters from the starter
  27. #    will be considered an option.
  28. #    Likewise, a double occurrence (e.g. "--") signals end of
  29. #    the options list.
  30. #    The default value for the starter is "-", "--" or "+".
  31. #
  32. # Upon return, the option variables, prefixed with "opt_", are defined
  33. # and set to the respective option arguments, if any.
  34. # Options that do not take an argument are set to 1. Note that an
  35. # option with an optional argument will be defined, but set to '' if
  36. # no actual argument has been supplied.
  37. # A return status of 0 (false) indicates that the function detected
  38. # one or more errors.
  39. #
  40. # Special care is taken to give a correct treatment to optional arguments.
  41. #
  42. # E.g. if option "one:i" (i.e. takes an optional integer argument),
  43. # then the following situations are handled:
  44. #
  45. #    -one -two        -> $opt_one = '', -two is next option
  46. #    -one -2        -> $opt_one = -2
  47. #
  48. # Also, assume "foo=s" and "bar:s" :
  49. #
  50. #    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  51. #    -foo -bar        -> $opt_foo = '-bar'
  52. #    -foo --        -> $opt_foo = '--'
  53. #
  54. # HISTORY 
  55. # 2-Jun-1992        Johan Vromans    
  56. #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
  57. #    Prevent typeless option from using previous $array state.
  58. #    Prevent empty option from being eaten as a (negative) number.
  59.  
  60. # 25-May-1992        Johan Vromans    
  61. #    Add array options. "foo=s@" will return an array @opt_foo that
  62. #    contains all values that were supplied. E.g. "-foo one -foo -two" will
  63. #    return @opt_foo = ("one", "-two");
  64. #    Correct bug in handling options that allow for a argument when followed
  65. #    by another option.
  66.  
  67. # 4-May-1992        Johan Vromans    
  68. #    Add $ignorecase to match options in either case.
  69. #    Allow '' option.
  70.  
  71. # 19-Mar-1992        Johan Vromans    
  72. #    Allow require from packages.
  73. #    NGetOpt is now defined in the package that requires it.
  74. #    @ARGV and $opt_... are taken from the package that calls it.
  75. #    Use standard (?) option prefixes: -, -- and +.
  76.  
  77. # 20-Sep-1990        Johan Vromans    
  78. #    Set options w/o argument to 1.
  79. #    Correct the dreadful semicolon/require bug.
  80.  
  81.  
  82. {   package newgetopt;
  83.     $debug = 0;            # for debugging
  84.     $ignorecase = 1;        # ignore case when matching options
  85. }
  86.  
  87. sub NGetOpt {
  88.  
  89.     @newgetopt'optionlist = @_;
  90.     *newgetopt'ARGV = *ARGV;
  91.  
  92.     package newgetopt;
  93.  
  94.     local ($[) = 0;
  95.     local ($genprefix) = "(--|-|\\+)";
  96.     local ($argend) = "--";
  97.     local ($error) = 0;
  98.     local ($opt, $optx, $arg, $type, $mand, %opctl);
  99.     local ($pkg) = (caller)[0];
  100.  
  101.     print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
  102.  
  103.     # See if the first element of the optionlist contains option
  104.     # starter characters.
  105.     if ( $optionlist[0] =~ /^\W+$/ ) {
  106.     $genprefix = shift (@optionlist);
  107.     # Turn into regexp.
  108.     $genprefix =~ s/(\W)/\\\1/g;
  109.     $genprefix = "[" . $genprefix . "]";
  110.     undef $argend;
  111.     }
  112.  
  113.     # Verify correctness of optionlist.
  114.     %opctl = ();
  115.     foreach $opt ( @optionlist ) {
  116.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  117.     if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
  118.         print STDERR ("Error in option spec: \"", $opt, "\"\n");
  119.         $error++;
  120.         next;
  121.     }
  122.     $opctl{$1} = defined $2 ? $2 : "";
  123.     }
  124.  
  125.     return 0 if $error;
  126.  
  127.     if ( $debug ) {
  128.     local ($arrow, $k, $v);
  129.     $arrow = "=> ";
  130.     while ( ($k,$v) = each(%opctl) ) {
  131.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  132.         $arrow = "   ";
  133.     }
  134.     }
  135.  
  136.     # Process argument list
  137.  
  138.     while ( $#ARGV >= 0 ) {
  139.  
  140.     # >>> See also the continue block <<<
  141.  
  142.     # Get next argument
  143.     $opt = shift (@ARGV);
  144.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  145.     $arg = undef;
  146.  
  147.     # Check for exhausted list.
  148.     if ( $opt =~ /^$genprefix/ ) {
  149.         # Double occurrence is terminator
  150.         return ($error == 0) 
  151.         if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
  152.         $opt = $';        # option name (w/o prefix)
  153.     }
  154.     else {
  155.         # Apparently not an option - push back and exit.
  156.         unshift (@ARGV, $opt);
  157.         return ($error == 0);
  158.     }
  159.  
  160.     # Look it up.
  161.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  162.     unless  ( defined ( $type = $opctl{$opt} ) ) {
  163.         print STDERR ("Unknown option: ", $opt, "\n");
  164.         $error++;
  165.         next;
  166.     }
  167.  
  168.     # Determine argument status.
  169.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  170.  
  171.     # If it is an option w/o argument, we're almost finished with it.
  172.     if ( $type eq "" ) {
  173.         $arg = 1;        # supply explicit value
  174.         $array = 0;
  175.         next;
  176.     }
  177.  
  178.     # Get mandatory status and type info.
  179.     ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
  180.  
  181.     # Check if the argument list is exhausted.
  182.     if ( $#ARGV < 0 ) {
  183.  
  184.         # Complain if this option needs an argument.
  185.         if ( $mand eq "=" ) {
  186.         print STDERR ("Option ", $opt, " requires an argument\n");
  187.         $error++;
  188.         }
  189.         if ( $mand eq ":" ) {
  190.         $arg = $type eq "s" ? "" : 0;
  191.         }
  192.         next;
  193.     }
  194.  
  195.     # Get (possibly optional) argument.
  196.     $arg = shift (@ARGV);
  197.  
  198.     # Check if it is a valid argument. A mandatory string takes
  199.     # anything. 
  200.     if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
  201.  
  202.         # Check for option list terminator.
  203.         if ( $arg eq "$+$+" || 
  204.          ((defined $argend) && $arg eq $argend)) {
  205.         # Push back so the outer loop will terminate.
  206.         unshift (@ARGV, $arg);
  207.         # Complain if an argument is required.
  208.         if ($mand eq "=") {
  209.             print STDERR ("Option ", $opt, " requires an argument\n");
  210.             $error++;
  211.             undef $arg;    # don't assign it
  212.         }
  213.         else {
  214.             # Supply empty value.
  215.             $arg = $type eq "s" ? "" : 0;
  216.         }
  217.         next;
  218.         }
  219.  
  220.         # Maybe the optional argument is the next option?
  221.         if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
  222.         # Yep. Push back.
  223.         unshift (@ARGV, $arg);
  224.         $arg = $type eq "s" ? "" : 0;
  225.         next;
  226.         }
  227.     }
  228.  
  229.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  230.         if ( $arg !~ /^-?[0-9]+$/ ) {
  231.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  232.                   $opt, " (number expected)\n");
  233.         $error++;
  234.         undef $arg;    # don't assign it
  235.         }
  236.         next;
  237.     }
  238.  
  239.     if ( $type eq "f" ) { # fixed real number, int is also ok
  240.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  241.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  242.                   $opt, " (real number expected)\n");
  243.         $error++;
  244.         undef $arg;    # don't assign it
  245.         }
  246.         next;
  247.     }
  248.  
  249.     if ( $type eq "s" ) { # string
  250.         next;
  251.     }
  252.  
  253.     }
  254.     continue {
  255.     if ( defined $arg ) {
  256.         if ( $array ) {
  257.         print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
  258.             if $debug;
  259.             eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
  260.         }
  261.         else {
  262.         print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
  263.             if $debug;
  264.             eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
  265.         }
  266.     }
  267.     }
  268.  
  269.     return ($error == 0);
  270. }
  271. 1;
  272.