home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / Getopt / Long.pm next >
Text File  |  1995-07-03  |  20KB  |  653 lines
  1. package Getopt::Long;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(GetOptions);
  7.  
  8. =head1 NAME
  9.  
  10. GetOptions - extended getopt processing
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.     use Getopt::Long;
  15.     $result = GetOptions (...option-descriptions...);
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. The Getopt::Long module implements an extended getopt function called
  20. GetOptions(). This function adheres to the new syntax (long option names,
  21. no bundling).  It tries to implement the better functionality of
  22. traditional, GNU and POSIX getopt() functions.
  23.  
  24. Each description should designate a valid Perl identifier, optionally
  25. followed by an argument specifier.
  26.  
  27. Values for argument specifiers are:
  28.  
  29.   <none>   option does not take an argument
  30.   !        option does not take an argument and may be negated
  31.   =s :s    option takes a mandatory (=) or optional (:) string argument
  32.   =i :i    option takes a mandatory (=) or optional (:) integer argument
  33.   =f :f    option takes a mandatory (=) or optional (:) real number argument
  34.  
  35. If option "name" is set, it will cause the Perl variable $opt_name to
  36. be set to the specified value. The calling program can use this
  37. variable to detect whether the option has been set. Options that do
  38. not take an argument will be set to 1 (one).
  39.  
  40. Options that take an optional argument will be defined, but set to ''
  41. if no actual argument has been supplied.
  42.  
  43. If an "@" sign is appended to the argument specifier, the option is
  44. treated as an array.  Value(s) are not set, but pushed into array
  45. @opt_name.
  46.  
  47. Options that do not take a value may have an "!" argument specifier to
  48. indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which
  49. sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0).
  50.  
  51. The option name may actually be a list of option names, separated by
  52. '|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and
  53. 'blech' will set $opt_foo instead.
  54.  
  55. Option names may be abbreviated to uniqueness, depending on
  56. configuration variable $autoabbrev.
  57.  
  58. Dashes in option names are allowed (e.g. pcc-struct-return) and will
  59. be translated to underscores in the corresponding Perl variable (e.g.
  60. $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
  61. option, corresponding Perl identifier is $opt_ .
  62.  
  63. A double dash "--" signals end of the options list.
  64.  
  65. If the first option of the list consists of non-alphanumeric
  66. characters only, it is interpreted as a generic option starter.
  67. Everything starting with one of the characters from the starter will
  68. be considered an option.
  69.  
  70. The default values for the option starters are "-" (traditional), "--"
  71. (POSIX) and "+" (GNU, being phased out).
  72.  
  73. Options that start with "--" may have an argument appended, separated
  74. with an "=", e.g. "--foo=bar".
  75.  
  76. If configuration variable $getopt_compat is set to a non-zero value,
  77. options that start with "+" may also include their arguments,
  78. e.g. "+foo=bar".
  79.  
  80. A return status of 0 (false) indicates that the function detected
  81. one or more errors.
  82.  
  83. =head1 EXAMPLES
  84.  
  85. If option "one:i" (i.e. takes an optional integer argument), then
  86. the following situations are handled:
  87.  
  88.    -one -two        -> $opt_one = '', -two is next option
  89.    -one -2        -> $opt_one = -2
  90.  
  91. Also, assume "foo=s" and "bar:s" :
  92.  
  93.    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  94.    -foo -bar        -> $opt_foo = '-bar'
  95.    -foo --        -> $opt_foo = '--'
  96.  
  97. In GNU or POSIX format, option names and values can be combined:
  98.  
  99.    +foo=blech        -> $opt_foo = 'blech'
  100.    --bar=        -> $opt_bar = ''
  101.    --bar=--        -> $opt_bar = '--'
  102.  
  103. =over 12
  104.  
  105. =item $autoabbrev      
  106.  
  107. Allow option names to be abbreviated to uniqueness.
  108. Default is 1 unless environment variable
  109. POSIXLY_CORRECT has been set.
  110.  
  111. =item $getopt_compat   
  112.  
  113. Allow '+' to start options.
  114. Default is 1 unless environment variable
  115. POSIXLY_CORRECT has been set.
  116.  
  117. =item $option_start    
  118.  
  119. Regexp with option starters.
  120. Default is (--|-) if environment variable
  121. POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
  122.  
  123. =item $order           
  124.  
  125. Whether non-options are allowed to be mixed with
  126. options.
  127. Default is $REQUIRE_ORDER if environment variable
  128. POSIXLY_CORRECT has been set, $PERMUTE otherwise.
  129.  
  130. =item $ignorecase      
  131.  
  132. Ignore case when matching options. Default is 1.
  133.  
  134. =item $debug           
  135.  
  136. Enable debugging output. Default is 0.
  137.  
  138. =back
  139.  
  140. =head1 NOTE
  141.  
  142. Does not yet use the Exporter--or even packages!!
  143. Thus, it's not a real module.
  144.  
  145. =cut
  146.  
  147. # newgetopt.pl -- new options parsing
  148.  
  149. # SCCS Status     : @(#)@ newgetopt.pl    1.14
  150. # Author          : Johan Vromans
  151. # Created On      : Tue Sep 11 15:00:12 1990
  152. # Last Modified By: Johan Vromans
  153. # Last Modified On: Sat Feb 12 18:24:02 1994
  154. # Update Count    : 138
  155. # Status          : Okay
  156.  
  157. ################ Introduction ################
  158. #
  159. # This package implements an extended getopt function. This function adheres
  160. # to the new syntax (long option names, no bundling).
  161. # It tries to implement the better functionality of traditional, GNU and
  162. # POSIX getopt functions.
  163. # 
  164. # This program is Copyright 1990,1994 by Johan Vromans.
  165. # This program is free software; you can redistribute it and/or
  166. # modify it under the terms of the GNU General Public License
  167. # as published by the Free Software Foundation; either version 2
  168. # of the License, or (at your option) any later version.
  169. # 
  170. # This program is distributed in the hope that it will be useful,
  171. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  172. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  173. # GNU General Public License for more details.
  174. # 
  175. # If you do not have a copy of the GNU General Public License write to
  176. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
  177. # MA 02139, USA.
  178.  
  179. ################ Description ################
  180. #
  181. # Usage:
  182. # 
  183. #    require "newgetopt.pl";
  184. #    ...change configuration values, if needed...
  185. #    $result = &NGetOpt (...option-descriptions...);
  186. # 
  187. # Each description should designate a valid perl identifier, optionally
  188. # followed by an argument specifier.
  189. # 
  190. # Values for argument specifiers are:
  191. # 
  192. #   <none>   option does not take an argument
  193. #   !        option does not take an argument and may be negated
  194. #   =s :s    option takes a mandatory (=) or optional (:) string argument
  195. #   =i :i    option takes a mandatory (=) or optional (:) integer argument
  196. #   =f :f    option takes a mandatory (=) or optional (:) real number argument
  197. # 
  198. # If option "name" is set, it will cause the perl variable $opt_name to
  199. # be set to the specified value. The calling program can use this
  200. # variable to detect whether the option has been set. Options that do
  201. # not take an argument will be set to 1 (one).
  202. # 
  203. # Options that take an optional argument will be defined, but set to ''
  204. # if no actual argument has been supplied.
  205. # 
  206. # If an "@" sign is appended to the argument specifier, the option is
  207. # treated as an array. Value(s) are not set, but pushed into array
  208. # @opt_name.
  209. # 
  210. # Options that do not take a value may have an "!" argument spacifier to
  211. # indicate that they may be negated. E.g. "foo!" will allow -foo (which
  212. # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
  213. # 
  214. # The option name may actually be a list of option names, separated by
  215. # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
  216. # 'blech' will set $opt_foo instead.
  217. # 
  218. # Option names may be abbreviated to uniqueness, depending on
  219. # configuration variable $autoabbrev.
  220. # 
  221. # Dashes in option names are allowed (e.g. pcc-struct-return) and will
  222. # be translated to underscores in the corresponding perl variable (e.g.
  223. # $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
  224. # option, corresponding perl identifier is $opt_ .
  225. # 
  226. # A double dash "--" signals end of the options list.
  227. # 
  228. # If the first option of the list consists of non-alphanumeric
  229. # characters only, it is interpreted as a generic option starter.
  230. # Everything starting with one of the characters from the starter will
  231. # be considered an option.
  232. # 
  233. # The default values for the option starters are "-" (traditional), "--"
  234. # (POSIX) and "+" (GNU, being phased out).
  235. # 
  236. # Options that start with "--" may have an argument appended, separated
  237. # with an "=", e.g. "--foo=bar".
  238. # 
  239. # If configuration varaible $getopt_compat is set to a non-zero value,
  240. # options that start with "+" may also include their arguments,
  241. # e.g. "+foo=bar".
  242. # 
  243. # A return status of 0 (false) indicates that the function detected
  244. # one or more errors.
  245. #
  246. ################ Some examples ################
  247. # 
  248. # If option "one:i" (i.e. takes an optional integer argument), then
  249. # the following situations are handled:
  250. # 
  251. #    -one -two        -> $opt_one = '', -two is next option
  252. #    -one -2        -> $opt_one = -2
  253. # 
  254. # Also, assume "foo=s" and "bar:s" :
  255. # 
  256. #    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  257. #    -foo -bar        -> $opt_foo = '-bar'
  258. #    -foo --        -> $opt_foo = '--'
  259. # 
  260. # In GNU or POSIX format, option names and values can be combined:
  261. # 
  262. #    +foo=blech        -> $opt_foo = 'blech'
  263. #    --bar=        -> $opt_bar = ''
  264. #    --bar=--        -> $opt_bar = '--'
  265. # 
  266. ################ Configuration values ################
  267. # 
  268. #   $autoabbrev      Allow option names to be abbreviated to uniqueness.
  269. #                    Default is 1 unless environment variable
  270. #                    POSIXLY_CORRECT has been set.
  271. # 
  272. #   $getopt_compat   Allow '+' to start options.
  273. #                    Default is 1 unless environment variable
  274. #                    POSIXLY_CORRECT has been set.
  275. # 
  276. #   $option_start    Regexp with option starters.
  277. #                    Default is (--|-) if environment variable
  278. #                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
  279. # 
  280. #   $order           Whether non-options are allowed to be mixed with
  281. #                    options.
  282. #                    Default is $REQUIRE_ORDER if environment variable
  283. #                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
  284. # 
  285. #   $ignorecase      Ignore case when matching options. Default is 1.
  286. # 
  287. #   $debug           Enable debugging output. Default is 0.
  288.  
  289. ################ History ################
  290. # 
  291. # 12-Feb-1994        Johan Vromans    
  292. #    Added "!" for negation.
  293. #    Released to the net.
  294. #
  295. # 26-Aug-1992        Johan Vromans    
  296. #    More POSIX/GNU compliance.
  297. #    Lone dash and double-dash are now independent of the option prefix
  298. #      that is used.
  299. #    Make errors in NGetOpt parameters fatal.
  300. #    Allow options to be mixed with arguments.
  301. #      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
  302. #    Allow --foo=bar and +foo=bar (but not -foo=bar).
  303. #    Allow options to be abbreviated to minimum needed for uniqueness.
  304. #      (Controlled by configuration variable $autoabbrev.)
  305. #    Allow alias names for options (e.g. "foo|bar=s").
  306. #    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
  307. #      translated to "_" to form valid perl identifiers
  308. #      (e.g. $opt_pcc_struct_return). 
  309. #
  310. # 2-Jun-1992        Johan Vromans    
  311. #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
  312. #    Prevent typeless option from using previous $array state.
  313. #    Prevent empty option from being eaten as a (negative) number.
  314. #
  315. # 25-May-1992        Johan Vromans    
  316. #    Add array options. "foo=s@" will return an array @opt_foo that
  317. #    contains all values that were supplied. E.g. "-foo one -foo -two" will
  318. #    return @opt_foo = ("one", "-two");
  319. #    Correct bug in handling options that allow for a argument when followed
  320. #    by another option.
  321. #
  322. # 4-May-1992        Johan Vromans    
  323. #    Add $ignorecase to match options in either case.
  324. #    Allow '' option.
  325. #
  326. # 19-Mar-1992        Johan Vromans    
  327. #    Allow require from packages.
  328. #    NGetOpt is now defined in the package that requires it.
  329. #    @ARGV and $opt_... are taken from the package that calls it.
  330. #    Use standard (?) option prefixes: -, -- and +.
  331. #
  332. # 20-Sep-1990        Johan Vromans    
  333. #    Set options w/o argument to 1.
  334. #    Correct the dreadful semicolon/require bug.
  335.  
  336. ################ Configuration Section ################
  337.  
  338. { 
  339.  
  340.     # Values for $order. See GNU getopt.c for details.
  341.     $REQUIRE_ORDER = 0;
  342.     $PERMUTE = 1;
  343.     $RETURN_IN_ORDER = 2;
  344.     $RETURN_IN_ORDER = 2; # avoid typo warning with -w
  345.  
  346.     # Handle POSIX compliancy.
  347.     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
  348.     $autoabbrev = 0;    # no automatic abbrev of options (???)
  349.     $getopt_compat = 0;    # disallow '+' to start options
  350.     $option_start = "(--|-)";
  351.     $order = $REQUIRE_ORDER;
  352.     }
  353.     else {
  354.     $autoabbrev = 1;    # automatic abbrev of options
  355.     $getopt_compat = 1;    # allow '+' to start options
  356.     $option_start = "(--|-|\\+)";
  357.     $order = $PERMUTE;
  358.     }
  359.  
  360.     # Other configurable settings.
  361.     $debug = 0;            # for debugging
  362.     $ignorecase = 1;        # ignore case when matching options
  363.     $argv_end = "--";        # don't change this!
  364. }
  365.  
  366. ################ Subroutines ################
  367.  
  368. sub GetOptions {
  369.  
  370.     @optionlist = @_;    #';
  371.  
  372.     local ($[) = 0;
  373.     local ($genprefix) = $option_start;
  374.     local ($argend) = $argv_end;
  375.     local ($error) = 0;
  376.     local ($opt, $arg, $type, $mand, %opctl);
  377.     local ($pkg) = (caller)[0];
  378.     local ($optarg);
  379.     local (%aliases);
  380.     local (@ret) = ();
  381.  
  382.     print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
  383.  
  384.     # See if the first element of the optionlist contains option
  385.     # starter characters.
  386.     if ( $optionlist[0] =~ /^\W+$/ ) {
  387.     $genprefix = shift (@optionlist);
  388.     # Turn into regexp.
  389.     $genprefix =~ s/(\W)/\\$1/g;
  390.     $genprefix = "[" . $genprefix . "]";
  391.     }
  392.  
  393.     # Verify correctness of optionlist.
  394.     %opctl = ();
  395.     foreach $opt ( @optionlist ) {
  396.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  397.     if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
  398.         die ("Error in option spec: \"", $opt, "\"\n");
  399.         $error++;
  400.         next;
  401.     }
  402.     local ($o, $c, $a) = ($1, $2);
  403.  
  404.     if ( ! defined $o ) {
  405.         $opctl{''} = defined $c ? $c : '';
  406.     }
  407.     else {
  408.         # Handle alias names
  409.         foreach ( split (/\|/, $o)) {
  410.         if ( defined $c && $c eq '!' ) {
  411.             $opctl{"no$_"} = $c;
  412.             $c = '';
  413.         }
  414.         $opctl{$_} = defined $c ? $c : '';
  415.         if ( defined $a ) {
  416.             # Note alias.
  417.             $aliases{$_} = $a;
  418.         }
  419.         else {
  420.             # Set primary name.
  421.             $a = $_;
  422.         }
  423.         }
  424.     }
  425.     }
  426.     @opctl = sort(keys (%opctl)) if $autoabbrev;
  427.  
  428.     return 0 if $error;
  429.  
  430.     if ( $debug ) {
  431.     local ($arrow, $k, $v);
  432.     $arrow = "=> ";
  433.     while ( ($k,$v) = each(%opctl) ) {
  434.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  435.         $arrow = "   ";
  436.     }
  437.     }
  438.  
  439.     # Process argument list
  440.  
  441.     while ( $#ARGV >= 0 ) {
  442.  
  443.     # >>> See also the continue block <<<
  444.  
  445.     #### Get next argument ####
  446.  
  447.     $opt = shift (@ARGV);
  448.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  449.     $arg = undef;
  450.     $optarg = undef;
  451.     $array = 0;
  452.  
  453.     #### Determine what we have ####
  454.  
  455.     # Double dash is option list terminator.
  456.     if ( $opt eq $argend ) {
  457.         unshift (@ARGV, @ret) if $order == $PERMUTE;
  458.         return ($error == 0);
  459.     }
  460.     elsif ( $opt =~ /^$genprefix/ ) {
  461.         # Looks like an option.
  462.         $opt = $';        # option name (w/o prefix)
  463.         # If it is a long opt, it may include the value.
  464.         if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
  465.         $opt =~ /^([^=]+)=/ ) {
  466.         $opt = $1;
  467.         $optarg = $';
  468.         print STDERR ("=> option \"", $opt, 
  469.                   "\", optarg = \"$optarg\"\n")
  470.             if $debug;
  471.         }
  472.  
  473.     }
  474.     # Not an option. Save it if we may permute...
  475.     elsif ( $order == $PERMUTE ) {
  476.         push (@ret, $opt);
  477.         next;
  478.     }
  479.     # ...otherwise, terminate.
  480.     else {
  481.         # Push back and exit.
  482.         unshift (@ARGV, $opt);
  483.         return ($error == 0);
  484.     }
  485.  
  486.     #### Look it up ###
  487.  
  488.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  489.  
  490.     local ($tryopt) = $opt;
  491.     if ( $autoabbrev ) {
  492.         local ($pat, @hits);
  493.  
  494.         # Turn option name into pattern.
  495.         ($pat = $opt) =~ s/(\W)/\\$1/g;
  496.         # Look up in option names.
  497.         @hits = grep (/^$pat/, @opctl);
  498.         print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
  499.               "out of ", 0+@opctl, "\n")
  500.         if $debug;
  501.  
  502.         # Check for ambiguous results.
  503.         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  504.         print STDERR ("Option ", $opt, " is ambiguous (",
  505.                   join(", ", @hits), ")\n");
  506.         $error++;
  507.         next;
  508.         }
  509.  
  510.         # Complete the option name, if appropriate.
  511.         if ( @hits == 1 && $hits[0] ne $opt ) {
  512.         $tryopt = $hits[0];
  513.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  514.             if $debug;
  515.         }
  516.     }
  517.  
  518.     unless  ( defined ( $type = $opctl{$tryopt} ) ) {
  519.         print STDERR ("Unknown option: ", $opt, "\n");
  520.         $error++;
  521.         next;
  522.     }
  523.     $opt = $tryopt;
  524.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  525.  
  526.     #### Determine argument status ####
  527.  
  528.     # If it is an option w/o argument, we're almost finished with it.
  529.     if ( $type eq '' || $type eq '!' ) {
  530.         if ( defined $optarg ) {
  531.         print STDERR ("Option ", $opt, " does not take an argument\n");
  532.         $error++;
  533.         }
  534.         elsif ( $type eq '' ) {
  535.         $arg = 1;        # supply explicit value
  536.         }
  537.         else {
  538.         substr ($opt, 0, 2) = ''; # strip NO prefix
  539.         $arg = 0;        # supply explicit value
  540.         }
  541.         next;
  542.     }
  543.  
  544.     # Get mandatory status and type info.
  545.     ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
  546.  
  547.     # Check if there is an option argument available.
  548.     if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
  549.  
  550.         # Complain if this option needs an argument.
  551.         if ( $mand eq "=" ) {
  552.         print STDERR ("Option ", $opt, " requires an argument\n");
  553.         $error++;
  554.         }
  555.         if ( $mand eq ":" ) {
  556.         $arg = $type eq "s" ? '' : 0;
  557.         }
  558.         next;
  559.     }
  560.  
  561.     # Get (possibly optional) argument.
  562.     $arg = defined $optarg ? $optarg : shift (@ARGV);
  563.  
  564.     #### Check if the argument is valid for this option ####
  565.  
  566.     if ( $type eq "s" ) {    # string
  567.         # A mandatory string takes anything. 
  568.         next if $mand eq "=";
  569.  
  570.         # An optional string takes almost anything. 
  571.         next if defined $optarg;
  572.         next if $arg eq "-";
  573.  
  574.         # Check for option or option list terminator.
  575.         if ($arg eq $argend ||
  576.         $arg =~ /^$genprefix.+/) {
  577.         # Push back.
  578.         unshift (@ARGV, $arg);
  579.         # Supply empty value.
  580.         $arg = '';
  581.         }
  582.         next;
  583.     }
  584.  
  585.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  586.         if ( $arg !~ /^-?[0-9]+$/ ) {
  587.         if ( defined $optarg || $mand eq "=" ) {
  588.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  589.                   $opt, " (number expected)\n");
  590.             $error++;
  591.             undef $arg;    # don't assign it
  592.         }
  593.         else {
  594.             # Push back.
  595.             unshift (@ARGV, $arg);
  596.             # Supply default value.
  597.             $arg = 0;
  598.         }
  599.         }
  600.         next;
  601.     }
  602.  
  603.     if ( $type eq "f" ) { # fixed real number, int is also ok
  604.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  605.         if ( defined $optarg || $mand eq "=" ) {
  606.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  607.                   $opt, " (real number expected)\n");
  608.             $error++;
  609.             undef $arg;    # don't assign it
  610.         }
  611.         else {
  612.             # Push back.
  613.             unshift (@ARGV, $arg);
  614.             # Supply default value.
  615.             $arg = 0.0;
  616.         }
  617.         }
  618.         next;
  619.     }
  620.  
  621.     die ("NGetOpt internal error (Can't happen)\n");
  622.     }
  623.  
  624.     continue {
  625.     if ( defined $arg ) {
  626.         $opt = $aliases{$opt} if defined $aliases{$opt};
  627.         # Make sure a valid perl identifier results.
  628.         $opt =~ s/\W/_/g;
  629.         if ( $array ) {
  630.         print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
  631.             if $debug;
  632.             eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
  633.         }
  634.         else {
  635.         print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
  636.             if $debug;
  637.             eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
  638.         }
  639.     }
  640.     }
  641.  
  642.     if ( $order == $PERMUTE && @ret > 0 ) {
  643.     unshift (@ARGV, @ret);
  644.     }
  645.     return ($error == 0);
  646. }
  647.  
  648. ################ Package return ################
  649.  
  650. 1;
  651.  
  652.  
  653.