home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-bin.lha / lib / perl5 / Getopt / Long.pm next >
Encoding:
Perl POD Document  |  1996-10-10  |  25.0 KB  |  892 lines
  1. # GetOpt::Long.pm -- POSIX compatible options parsing
  2.  
  3. # RCS Status      : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 jv Exp $
  4. # Author          : Johan Vromans
  5. # Created On      : Tue Sep 11 15:00:12 1990
  6. # Last Modified By: Johan Vromans
  7. # Last Modified On: Fri Feb  2 21:24:32 1996
  8. # Update Count    : 347
  9. # Status          : Released
  10.  
  11. package Getopt::Long;
  12. require 5.000;
  13. require Exporter;
  14.  
  15. @ISA = qw(Exporter);
  16. @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
  17. $VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
  18. use strict;
  19.  
  20. =head1 NAME
  21.  
  22. GetOptions - extended processing of command line options
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.   use Getopt::Long;
  27.   $result = GetOptions (...option-descriptions...);
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. The Getopt::Long module implements an extended getopt function called
  32. GetOptions(). This function adheres to the POSIX syntax for command
  33. line options, with GNU extensions. In general, this means that options
  34. have long names instead of single letters, and are introduced with a
  35. double dash "--". There is no bundling of command line options, as was
  36. the case with the more traditional single-letter approach. For
  37. example, the UNIX "ps" command can be given the command line "option" 
  38.  
  39.   -vax
  40.  
  41. which means the combination of B<-v>, B<-a> and B<-x>. With the new
  42. syntax B<--vax> would be a single option, probably indicating a
  43. computer architecture. 
  44.  
  45. Command line options can be used to set values. These values can be
  46. specified in one of two ways:
  47.  
  48.   --size 24
  49.   --size=24
  50.  
  51. GetOptions is called with a list of option-descriptions, each of which
  52. consists of two elements: the option specifier and the option linkage.
  53. The option specifier defines the name of the option and, optionally,
  54. the value it can take. The option linkage is usually a reference to a
  55. variable that will be set when the option is used. For example, the
  56. following call to GetOptions:
  57.  
  58.   &GetOptions("size=i" => \$offset);
  59.  
  60. will accept a command line option "size" that must have an integer
  61. value. With a command line of "--size 24" this will cause the variable
  62. $offset to get the value 24.
  63.  
  64. Alternatively, the first argument to GetOptions may be a reference to
  65. a HASH describing the linkage for the options. The following call is
  66. equivalent to the example above:
  67.  
  68.   %optctl = ("size" => \$offset);
  69.   &GetOptions(\%optctl, "size=i");
  70.  
  71. Linkage may be specified using either of the above methods, or both.
  72. Linkage specified in the argument list takes precedence over the
  73. linkage specified in the HASH.
  74.  
  75. The command line options are taken from array @ARGV. Upon completion
  76. of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
  77. the command line.
  78.  
  79. Each option specifier designates the name of the option, optionally
  80. followed by an argument specifier. Values for argument specifiers are:
  81.  
  82. =over 8
  83.  
  84. =item <none>
  85.  
  86. Option does not take an argument. 
  87. The option variable will be set to 1.
  88.  
  89. =item !
  90.  
  91. Option does not take an argument and may be negated, i.e. prefixed by
  92. "no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
  93. (with value 0).
  94. The option variable will be set to 1, or 0 if negated.
  95.  
  96. =item =s
  97.  
  98. Option takes a mandatory string argument.
  99. This string will be assigned to the option variable.
  100. Note that even if the string argument starts with B<-> or B<-->, it
  101. will not be considered an option on itself.
  102.  
  103. =item :s
  104.  
  105. Option takes an optional string argument.
  106. This string will be assigned to the option variable.
  107. If omitted, it will be assigned "" (an empty string).
  108. If the string argument starts with B<-> or B<-->, it
  109. will be considered an option on itself.
  110.  
  111. =item =i
  112.  
  113. Option takes a mandatory integer argument.
  114. This value will be assigned to the option variable.
  115. Note that the value may start with B<-> to indicate a negative
  116. value. 
  117.  
  118. =item :i
  119.  
  120. Option takes an optional integer argument.
  121. This value will be assigned to the option variable.
  122. If omitted, the value 0 will be assigned.
  123. Note that the value may start with B<-> to indicate a negative
  124. value.
  125.  
  126. =item =f
  127.  
  128. Option takes a mandatory real number argument.
  129. This value will be assigned to the option variable.
  130. Note that the value may start with B<-> to indicate a negative
  131. value.
  132.  
  133. =item :f
  134.  
  135. Option takes an optional real number argument.
  136. This value will be assigned to the option variable.
  137. If omitted, the value 0 will be assigned.
  138.  
  139. =back
  140.  
  141. A lone dash B<-> is considered an option, the corresponding option
  142. name is the empty string.
  143.  
  144. A double dash on itself B<--> signals end of the options list.
  145.  
  146. =head2 Linkage specification
  147.  
  148. The linkage specifier is optional. If no linkage is explicitly
  149. specified but a ref HASH is passed, GetOptions will place the value in
  150. the HASH. For example:
  151.  
  152.   %optctl = ();
  153.   &GetOptions (\%optctl, "size=i");
  154.  
  155. will perform the equivalent of the assignment
  156.  
  157.   $optctl{"size"} = 24;
  158.  
  159. For array options, a reference to an array is used, e.g.:
  160.  
  161.   %optctl = ();
  162.   &GetOptions (\%optctl, "sizes=i@");
  163.  
  164. with command line "-sizes 24 -sizes 48" will perform the equivalent of
  165. the assignment
  166.  
  167.   $optctl{"sizes"} = [24, 48];
  168.  
  169. If no linkage is explicitly specified and no ref HASH is passed,
  170. GetOptions will put the value in a global variable named after the
  171. option, prefixed by "opt_". To yield a usable Perl variable,
  172. characters that are not part of the syntax for variables are
  173. translated to underscores. For example, "--fpp-struct-return" will set
  174. the variable $opt_fpp_struct_return. Note that this variable resides
  175. in the namespace of the calling program, not necessarily B<main>.
  176. For example:
  177.  
  178.   &GetOptions ("size=i", "sizes=i@");
  179.  
  180. with command line "-size 10 -sizes 24 -sizes 48" will perform the
  181. equivalent of the assignments
  182.  
  183.   $opt_size = 10;
  184.   @opt_sizes = (24, 48);
  185.  
  186. A lone dash B<-> is considered an option, the corresponding Perl
  187. identifier is $opt_ .
  188.  
  189. The linkage specifier can be a reference to a scalar, a reference to
  190. an array or a reference to a subroutine.
  191.  
  192. If a REF SCALAR is supplied, the new value is stored in the referenced
  193. variable. If the option occurs more than once, the previous value is
  194. overwritten. 
  195.  
  196. If a REF ARRAY is supplied, the new value is appended (pushed) to the
  197. referenced array. 
  198.  
  199. If a REF CODE is supplied, the referenced subroutine is called with
  200. two arguments: the option name and the option value.
  201. The option name is always the true name, not an abbreviation or alias.
  202.  
  203. =head2 Aliases and abbreviations
  204.  
  205. The option name may actually be a list of option names, separated by
  206. "|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
  207. op this option. If no linkage is specified, options "foo", "bar" and
  208. "blech" all will set $opt_foo.
  209.  
  210. Option names may be abbreviated to uniqueness, depending on
  211. configuration variable $Getopt::Long::autoabbrev.
  212.  
  213. =head2 Non-option call-back routine
  214.  
  215. A special option specifier, <>, can be used to designate a subroutine
  216. to handle non-option arguments. GetOptions will immediately call this
  217. subroutine for every non-option it encounters in the options list.
  218. This subroutine gets the name of the non-option passed.
  219. This feature requires $Getopt::Long::order to have the value $PERMUTE.
  220. See also the examples.
  221.  
  222. =head2 Option starters
  223.  
  224. On the command line, options can start with B<-> (traditional), B<-->
  225. (POSIX) and B<+> (GNU, now being phased out). The latter is not
  226. allowed if the environment variable B<POSIXLY_CORRECT> has been
  227. defined.
  228.  
  229. Options that start with "--" may have an argument appended, separated
  230. with an "=", e.g. "--foo=bar".
  231.  
  232. =head2 Return value
  233.  
  234. A return status of 0 (false) indicates that the function detected
  235. one or more errors.
  236.  
  237. =head1 COMPATIBILITY
  238.  
  239. Getopt::Long::GetOptions() is the successor of
  240. B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
  241. In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
  242. the module.
  243.  
  244. If an "@" sign is appended to the argument specifier, the option is
  245. treated as an array.  Value(s) are not set, but pushed into array
  246. @opt_name. This only applies if no linkage is supplied.
  247.  
  248. If configuration variable $Getopt::Long::getopt_compat is set to a
  249. non-zero value, options that start with "+" may also include their
  250. arguments, e.g. "+foo=bar". This is for compatiblity with older
  251. implementations of the GNU "getopt" routine.
  252.  
  253. If the first argument to GetOptions is a string consisting of only
  254. non-alphanumeric characters, it is taken to specify the option starter
  255. characters. Everything starting with one of these characters from the
  256. starter will be considered an option. B<Using a starter argument is
  257. strongly deprecated.>
  258.  
  259. For convenience, option specifiers may have a leading B<-> or B<-->,
  260. so it is possible to write:
  261.  
  262.    GetOptions qw(-foo=s --bar=i --ar=s);
  263.  
  264. =head1 EXAMPLES
  265.  
  266. If the option specifier is "one:i" (i.e. takes an optional integer
  267. argument), then the following situations are handled:
  268.  
  269.    -one -two        -> $opt_one = '', -two is next option
  270.    -one -2        -> $opt_one = -2
  271.  
  272. Also, assume specifiers "foo=s" and "bar:s" :
  273.  
  274.    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  275.    -foo -bar        -> $opt_foo = '-bar'
  276.    -foo --        -> $opt_foo = '--'
  277.  
  278. In GNU or POSIX format, option names and values can be combined:
  279.  
  280.    +foo=blech        -> $opt_foo = 'blech'
  281.    --bar=        -> $opt_bar = ''
  282.    --bar=--        -> $opt_bar = '--'
  283.  
  284. Example of using variabel references:
  285.  
  286.    $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
  287.  
  288. With command line options "-foo blech -bar 24 -ar xx -ar yy" 
  289. this will result in:
  290.  
  291.    $bar = 'blech'
  292.    $opt_bar = 24
  293.    @ar = ('xx','yy')
  294.  
  295. Example of using the <> option specifier:
  296.  
  297.    @ARGV = qw(-foo 1 bar -foo 2 blech);
  298.    &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
  299.  
  300. Results:
  301.  
  302.    &mysub("bar") will be called (with $myfoo being 1)
  303.    &mysub("blech") will be called (with $myfoo being 2)
  304.  
  305. Compare this with:
  306.  
  307.    @ARGV = qw(-foo 1 bar -foo 2 blech);
  308.    &GetOptions("foo=i", \$myfoo);
  309.  
  310. This will leave the non-options in @ARGV:
  311.  
  312.    $myfoo -> 2
  313.    @ARGV -> qw(bar blech)
  314.  
  315. =head1 CONFIGURATION VARIABLES
  316.  
  317. The following variables can be set to change the default behaviour of
  318. GetOptions():
  319.  
  320. =over 12
  321.  
  322. =item $Getopt::Long::autoabbrev      
  323.  
  324. Allow option names to be abbreviated to uniqueness.
  325. Default is 1 unless environment variable
  326. POSIXLY_CORRECT has been set.
  327.  
  328. =item $Getopt::Long::getopt_compat   
  329.  
  330. Allow '+' to start options.
  331. Default is 1 unless environment variable
  332. POSIXLY_CORRECT has been set.
  333.  
  334. =item $Getopt::Long::order           
  335.  
  336. Whether non-options are allowed to be mixed with
  337. options.
  338. Default is $REQUIRE_ORDER if environment variable
  339. POSIXLY_CORRECT has been set, $PERMUTE otherwise.
  340.  
  341. $PERMUTE means that 
  342.  
  343.     -foo arg1 -bar arg2 arg3
  344.  
  345. is equivalent to
  346.  
  347.     -foo -bar arg1 arg2 arg3
  348.  
  349. If a non-option call-back routine is specified, @ARGV will always be
  350. empty upon succesful return of GetOptions since all options have been
  351. processed, except when B<--> is used:
  352.  
  353.     -foo arg1 -bar arg2 -- arg3
  354.  
  355. will call the call-back routine for arg1 and arg2, and terminate
  356. leaving arg2 in @ARGV.
  357.  
  358. If $Getopt::Long::order is $REQUIRE_ORDER, options processing
  359. terminates when the first non-option is encountered.
  360.  
  361.     -foo arg1 -bar arg2 arg3
  362.  
  363. is equivalent to
  364.  
  365.     -foo -- arg1 -bar arg2 arg3
  366.  
  367. $RETURN_IN_ORDER is not supported by GetOptions().
  368.  
  369. =item $Getopt::Long::ignorecase      
  370.  
  371. Ignore case when matching options. Default is 1.
  372.  
  373. =item $Getopt::Long::VERSION
  374.  
  375. The version number of this Getopt::Long implementation in the format
  376. C<major>.C<minor>. This can be used to have Exporter check the
  377. version, e.g.
  378.  
  379.     use Getopt::Long 2.00;
  380.  
  381. You can inspect $Getopt::Long::major_version and
  382. $Getopt::Long::minor_version for the individual components.
  383.  
  384. =item $Getopt::Long::error
  385.  
  386. Internal error flag. May be incremented from a call-back routine to
  387. cause options parsing to fail.
  388.  
  389. =item $Getopt::Long::debug           
  390.  
  391. Enable copious debugging output. Default is 0.
  392.  
  393. =back
  394.  
  395. =cut
  396.  
  397. ################ Introduction ################
  398. #
  399. # This package implements an extended getopt function. This function
  400. # adheres to the new syntax (long option names, no bundling). It tries
  401. # to implement the better functionality of traditional, GNU and POSIX
  402. # getopt functions.
  403. # 
  404. # This program is Copyright 1990,1996 by Johan Vromans.
  405. # This program is free software; you can redistribute it and/or
  406. # modify it under the terms of the GNU General Public License
  407. # as published by the Free Software Foundation; either version 2
  408. # of the License, or (at your option) any later version.
  409. # 
  410. # This program is distributed in the hope that it will be useful,
  411. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  412. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  413. # GNU General Public License for more details.
  414. # 
  415. # If you do not have a copy of the GNU General Public License write to
  416. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
  417. # MA 02139, USA.
  418.  
  419. ################ History ################
  420. # 
  421. # 13-Jan-1996        Johan Vromans
  422. #    Generalized the linkage interface.
  423. #    Eliminated the linkage argument.
  424. #    Add code references as a possible value for the option linkage.
  425. #    Add option specifier <> to have a call-back for non-options.
  426. #
  427. # 26-Dec-1995        Johan Vromans
  428. #    Import from netgetopt.pl.
  429. #    Turned into a decent module.
  430. #    Added linkage argument.
  431.  
  432. ################ Configuration Section ################
  433.  
  434. # Values for $order. See GNU getopt.c for details.
  435. ($Getopt::Long::REQUIRE_ORDER,
  436.  $Getopt::Long::PERMUTE, 
  437.  $Getopt::Long::RETURN_IN_ORDER) = (0..2);
  438.  
  439. my $gen_prefix;            # generic prefix (option starters)
  440.  
  441. # Handle POSIX compliancy.
  442. if ( defined $ENV{"POSIXLY_CORRECT"} ) {
  443.     $gen_prefix = "(--|-)";
  444.     $Getopt::Long::autoabbrev = 0;    # no automatic abbrev of options
  445.     $Getopt::Long::getopt_compat = 0;    # disallow '+' to start options
  446.     $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER;
  447. }
  448. else {
  449.     $gen_prefix = "(--|-|\\+)";
  450.     $Getopt::Long::autoabbrev = 1;    # automatic abbrev of options
  451.     $Getopt::Long::getopt_compat = 1;    # allow '+' to start options
  452.     $Getopt::Long::order = $Getopt::Long::PERMUTE;
  453. }
  454.  
  455. # Other configurable settings.
  456. $Getopt::Long::debug = 0;        # for debugging
  457. $Getopt::Long::error = 0;        # error tally
  458. $Getopt::Long::ignorecase = 1;        # ignore case when matching options
  459. ($Getopt::Long::version,
  460.  $Getopt::Long::major_version, 
  461.  $Getopt::Long::minor_version) = '$Revision: 2.1 $ ' =~ /: ((\d+)\.(\d+))/;
  462. $Getopt::Long::version .= '*' if length('$Locker:  $ ') > 12;
  463.  
  464. ################ Subroutines ################
  465.  
  466. sub GetOptions {
  467.  
  468.     my @optionlist = @_;    # local copy of the option descriptions
  469.     my $argend = '--';        # option list terminator
  470.     my %opctl;            # table of arg.specs
  471.     my $pkg = (caller)[0];    # current context
  472.                 # Needed if linkage is omitted.
  473.     my %aliases;        # alias table
  474.     my @ret = ();        # accum for non-options
  475.     my %linkage;        # linkage
  476.     my $userlinkage;        # user supplied HASH
  477.     my $debug = $Getopt::Long::debug;    # convenience
  478.     my $genprefix = $gen_prefix; # so we can call the same module more 
  479.                 # than once in differing environments
  480.     $Getopt::Long::error = 0;
  481.  
  482.     print STDERR ("GetOptions $Getopt::Long::version",
  483.           " [GetOpt::Long $Getopt::Long::VERSION] -- ",
  484.           "called from package \"$pkg\".\n",
  485.           "  autoabbrev=$Getopt::Long::autoabbrev".
  486.           ",getopt_compat=$Getopt::Long::getopt_compat",
  487.           ",genprefix=\"$genprefix\"",
  488.           ",order=$Getopt::Long::order",
  489.           ",ignorecase=$Getopt::Long::ignorecase",
  490.           ".\n")
  491.     if $debug;
  492.  
  493.     # Check for ref HASH as first argument. 
  494.     $userlinkage = undef;
  495.     if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) {
  496.     $userlinkage = shift (@optionlist);
  497.     }
  498.  
  499.     # See if the first element of the optionlist contains option
  500.     # starter characters.
  501.     if ( $optionlist[0] =~ /^\W+$/ ) {
  502.     $genprefix = shift (@optionlist);
  503.     # Turn into regexp.
  504.     $genprefix =~ s/(\W)/\\$1/g;
  505.     $genprefix = "[" . $genprefix . "]";
  506.     }
  507.  
  508.     # Verify correctness of optionlist.
  509.     %opctl = ();
  510.     while ( @optionlist > 0 ) {
  511.     my $opt = shift (@optionlist);
  512.  
  513.     # Strip leading prefix so people can specify "-foo=i" if they like.
  514.     $opt = $' if $opt =~ /^($genprefix)+/;
  515.  
  516.     if ( $opt eq '<>' ) {
  517.         if ( (defined $userlinkage)
  518.         && !(@optionlist > 0 && ref($optionlist[0]))
  519.         && (exists $userlinkage->{$opt})
  520.         && ref($userlinkage->{$opt}) ) {
  521.         unshift (@optionlist, $userlinkage->{$opt});
  522.         }
  523.         unless ( @optionlist > 0 
  524.             && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
  525.         warn ("Option spec <> requires a reference to a subroutine\n");
  526.         $Getopt::Long::error++;
  527.         next;
  528.         }
  529.         $linkage{'<>'} = shift (@optionlist);
  530.         next;
  531.     }
  532.  
  533.     $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
  534.     if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
  535.         warn ("Error in option spec: \"", $opt, "\"\n");
  536.         $Getopt::Long::error++;
  537.         next;
  538.     }
  539.     my ($o, $c, $a) = ($1, $2);
  540.  
  541.     if ( ! defined $o ) {
  542.         # empty -> '-' option
  543.         $opctl{$o = ''} = defined $c ? $c : '';
  544.     }
  545.     else {
  546.         # Handle alias names
  547.         my @o =  split (/\|/, $o);
  548.         $o = $o[0];
  549.         foreach ( @o ) {
  550.         if ( defined $c && $c eq '!' ) {
  551.             $opctl{"no$_"} = $c;
  552.             $c = '';
  553.         }
  554.         $opctl{$_} = defined $c ? $c : '';
  555.         if ( defined $a ) {
  556.             # Note alias.
  557.             $aliases{$_} = $a;
  558.         }
  559.         else {
  560.             # Set primary name.
  561.             $a = $_;
  562.         }
  563.         }
  564.     }
  565.  
  566.     # If no linkage is supplied in the @optionlist, copy it from
  567.     # the userlinkage if available.
  568.     if ( defined $userlinkage ) {
  569.         unless ( @optionlist > 0 && ref($optionlist[0]) ) {
  570.         if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
  571.             print STDERR ("=> found userlinkage for \"$o\": ",
  572.                   "$userlinkage->{$o}\n")
  573.             if $debug;
  574.             unshift (@optionlist, $userlinkage->{$o});
  575.         }
  576.         else {
  577.             # Do nothing. Being undefined will be handled later.
  578.             next;
  579.         }
  580.         }
  581.     }
  582.  
  583.     # Copy the linkage. If omitted, link to global variable.
  584.     if ( @optionlist > 0 && ref($optionlist[0]) ) {
  585.         print STDERR ("=> link \"$o\" to $optionlist[0]\n")
  586.         if $debug;
  587.         if ( ref($optionlist[0]) eq 'SCALAR'
  588.         || ref($optionlist[0]) eq 'ARRAY'
  589.         || ref($optionlist[0]) eq 'CODE' ) {
  590.         $linkage{$o} = shift (@optionlist);
  591.         }
  592.         else {
  593.         warn ("Invalid option linkage for \"", $opt, "\"\n");
  594.         $Getopt::Long::error++;
  595.         }
  596.     }
  597.     else {
  598.         # Link to global $opt_XXX variable.
  599.         # Make sure a valid perl identifier results.
  600.         my $ov = $o;
  601.         $ov =~ s/\W/_/g;
  602.         if ( $c && $c =~ /@/ ) {
  603.         print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
  604.             if $debug;
  605.         eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
  606.         }
  607.         else {
  608.         print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
  609.             if $debug;
  610.         eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
  611.         }
  612.     }
  613.     }
  614.  
  615.     # Bail out if errors found.
  616.     return 0 if $Getopt::Long::error;
  617.  
  618.     # Sort the possible option names.
  619.     my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev;
  620.  
  621.     # Show if debugging.
  622.     if ( $debug ) {
  623.     my ($arrow, $k, $v);
  624.     $arrow = "=> ";
  625.     while ( ($k,$v) = each(%opctl) ) {
  626.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  627.         $arrow = "   ";
  628.     }
  629.     }
  630.  
  631.     my $opt;            # current option
  632.     my $arg;            # current option value
  633.     my $array;            # current option is array typed
  634.  
  635.     # Process argument list
  636.     while ( @ARGV > 0 ) {
  637.  
  638.     # >>> See also the continue block <<<
  639.  
  640.     #### Get next argument ####
  641.  
  642.     $opt = shift (@ARGV);
  643.     $arg = undef;
  644.     my $optarg = undef;
  645.     $array = 0;
  646.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  647.  
  648.     #### Determine what we have ####
  649.  
  650.     # Double dash is option list terminator.
  651.     if ( $opt eq $argend ) {
  652.         # Finish. Push back accumulated arguments and return.
  653.         unshift (@ARGV, @ret) 
  654.         if $Getopt::Long::order == $Getopt::Long::PERMUTE;
  655.         return ($Getopt::Long::error == 0);
  656.     }
  657.  
  658.     if ( $opt =~ /^$genprefix/ ) {
  659.         # Looks like an option.
  660.         $opt = $';        # option name (w/o prefix)
  661.         # If it is a long opt, it may include the value.
  662.         if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+"))
  663.         && $opt =~ /^([^=]+)=/ ) {
  664.         $opt = $1;
  665.         $optarg = $';
  666.         print STDERR ("=> option \"", $opt, 
  667.                   "\", optarg = \"$optarg\"\n") if $debug;
  668.         }
  669.  
  670.     }
  671.  
  672.     # Not an option. Save it if we $PERMUTE and don't have a <>.
  673.     elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
  674.         # Try non-options call-back.
  675.         my $cb;
  676.         if ( (defined ($cb = $linkage{'<>'})) ) {
  677.         &$cb($opt);
  678.         }
  679.         else {
  680.         push (@ret, $opt);
  681.         }
  682.         next;
  683.     }
  684.  
  685.     # ...otherwise, terminate.
  686.     else {
  687.         # Push this one back and exit.
  688.         unshift (@ARGV, $opt);
  689.         return ($Getopt::Long::error == 0);
  690.     }
  691.  
  692.     #### Look it up ###
  693.  
  694.     $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
  695.  
  696.     my $tryopt = $opt;
  697.     if ( $Getopt::Long::autoabbrev ) {
  698.         my $pat;
  699.  
  700.         # Turn option name into pattern.
  701.         ($pat = $opt) =~ s/(\W)/\\$1/g;
  702.         # Look up in option names.
  703.         my @hits = grep (/^$pat/, @opctl);
  704.         print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
  705.               "out of ", 0+@opctl, "\n") if $debug;
  706.  
  707.         # Check for ambiguous results.
  708.         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  709.         print STDERR ("Option ", $opt, " is ambiguous (",
  710.                   join(", ", @hits), ")\n");
  711.         $Getopt::Long::error++;
  712.         next;
  713.         }
  714.  
  715.         # Complete the option name, if appropriate.
  716.         if ( @hits == 1 && $hits[0] ne $opt ) {
  717.         $tryopt = $hits[0];
  718.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  719.             if $debug;
  720.         }
  721.     }
  722.  
  723.     my $type;
  724.     unless  ( defined ( $type = $opctl{$tryopt} ) ) {
  725.         print STDERR ("Unknown option: ", $opt, "\n");
  726.         $Getopt::Long::error++;
  727.         next;
  728.     }
  729.     $opt = $tryopt;
  730.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  731.  
  732.     #### Determine argument status ####
  733.  
  734.     # If it is an option w/o argument, we're almost finished with it.
  735.     if ( $type eq '' || $type eq '!' ) {
  736.         if ( defined $optarg ) {
  737.         print STDERR ("Option ", $opt, " does not take an argument\n");
  738.         $Getopt::Long::error++;
  739.         }
  740.         elsif ( $type eq '' ) {
  741.         $arg = 1;        # supply explicit value
  742.         }
  743.         else {
  744.         substr ($opt, 0, 2) = ''; # strip NO prefix
  745.         $arg = 0;        # supply explicit value
  746.         }
  747.         next;
  748.     }
  749.  
  750.     # Get mandatory status and type info.
  751.     my $mand;
  752.     ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
  753.  
  754.     # Check if there is an option argument available.
  755.     if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) {
  756.  
  757.         # Complain if this option needs an argument.
  758.         if ( $mand eq "=" ) {
  759.         print STDERR ("Option ", $opt, " requires an argument\n");
  760.         $Getopt::Long::error++;
  761.         }
  762.         if ( $mand eq ":" ) {
  763.         $arg = $type eq "s" ? '' : 0;
  764.         }
  765.         next;
  766.     }
  767.  
  768.     # Get (possibly optional) argument.
  769.     $arg = defined $optarg ? $optarg : shift (@ARGV);
  770.  
  771.     #### Check if the argument is valid for this option ####
  772.  
  773.     if ( $type eq "s" ) {    # string
  774.         # A mandatory string takes anything. 
  775.         next if $mand eq "=";
  776.  
  777.         # An optional string takes almost anything. 
  778.         next if defined $optarg;
  779.         next if $arg eq "-";
  780.  
  781.         # Check for option or option list terminator.
  782.         if ($arg eq $argend ||
  783.         $arg =~ /^$genprefix.+/) {
  784.         # Push back.
  785.         unshift (@ARGV, $arg);
  786.         # Supply empty value.
  787.         $arg = '';
  788.         }
  789.         next;
  790.     }
  791.  
  792.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  793.         if ( $arg !~ /^-?[0-9]+$/ ) {
  794.         if ( defined $optarg || $mand eq "=" ) {
  795.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  796.                   $opt, " (number expected)\n");
  797.             $Getopt::Long::error++;
  798.             undef $arg;    # don't assign it
  799.         }
  800.         else {
  801.             # Push back.
  802.             unshift (@ARGV, $arg);
  803.             # Supply default value.
  804.             $arg = 0;
  805.         }
  806.         }
  807.         next;
  808.     }
  809.  
  810.     if ( $type eq "f" ) { # fixed real number, int is also ok
  811.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  812.         if ( defined $optarg || $mand eq "=" ) {
  813.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  814.                   $opt, " (real number expected)\n");
  815.             $Getopt::Long::error++;
  816.             undef $arg;    # don't assign it
  817.         }
  818.         else {
  819.             # Push back.
  820.             unshift (@ARGV, $arg);
  821.             # Supply default value.
  822.             $arg = 0.0;
  823.         }
  824.         }
  825.         next;
  826.     }
  827.  
  828.     die ("GetOpt::Long internal error (Can't happen)\n");
  829.     }
  830.  
  831.     continue {
  832.     if ( defined $arg ) {
  833.         $opt = $aliases{$opt} if defined $aliases{$opt};
  834.  
  835.         if ( defined $linkage{$opt} ) {
  836.         print STDERR ("=> ref(\$L{$opt}) -> ",
  837.                   ref($linkage{$opt}), "\n") if $debug;
  838.  
  839.         if ( ref($linkage{$opt}) eq 'SCALAR' ) {
  840.             print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
  841.             ${$linkage{$opt}} = $arg;
  842.         }
  843.         elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
  844.             print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
  845.             if $debug;
  846.             push (@{$linkage{$opt}}, $arg);
  847.         }
  848.         elsif ( ref($linkage{$opt}) eq 'CODE' ) {
  849.             print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
  850.             if $debug;
  851.             &{$linkage{$opt}}($opt, $arg);
  852.         }
  853.         else {
  854.             print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
  855.                   "\" in linkage\n");
  856.             die ("Getopt::Long -- internal error!\n");
  857.         }
  858.         }
  859.         # No entry in linkage means entry in userlinkage.
  860.         elsif ( $array ) {
  861.         if ( defined $userlinkage->{$opt} ) {
  862.             print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
  863.             if $debug;
  864.             push (@{$userlinkage->{$opt}}, $arg);
  865.         }
  866.         else {
  867.             print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
  868.             if $debug;
  869.             $userlinkage->{$opt} = [$arg];
  870.         }
  871.         }
  872.         else {
  873.         print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
  874.         $userlinkage->{$opt} = $arg;
  875.         }
  876.     }
  877.     }
  878.  
  879.     # Finish.
  880.     if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
  881.     #  Push back accumulated arguments
  882.     unshift (@ARGV, @ret) if @ret > 0;
  883.     }
  884.  
  885.     return ($Getopt::Long::error == 0);
  886. }
  887.  
  888. ################ Package return ################
  889.  
  890. # Returning 1 is so boring...
  891. $Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;
  892.