home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / Std.pm < prev    next >
Text File  |  2003-11-07  |  8KB  |  297 lines
  1. package Getopt::Std;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. =head1 NAME
  6.  
  7. getopt - Process single-character switches with switch clustering
  8.  
  9. getopts - Process single-character switches with switch clustering
  10.  
  11. =head1 SYNOPSIS
  12.  
  13.     use Getopt::Std;
  14.  
  15.     getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
  16.     getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
  17.     getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
  18.               # Sets $opt_* as a side effect.
  19.     getopts('oif:', \%opts);  # options as above. Values in %opts
  20.  
  21. =head1 DESCRIPTION
  22.  
  23. The getopt() function processes single-character switches with switch
  24. clustering.  Pass one argument which is a string containing all switches
  25. that take an argument.  For each switch found, sets $opt_x (where x is the
  26. switch name) to the value of the argument if an argument is expected,
  27. or 1 otherwise.  Switches which take an argument don't care whether
  28. there is a space between the switch and the argument.
  29.  
  30. The getopts() function is similar, but you should pass to it the list of all
  31. switches to be recognized.  If unspecified switches are found on the
  32. command-line, the user will be warned that an unknown option was given.
  33.  
  34. Note that, if your code is running under the recommended C<use strict
  35. 'vars'> pragma, you will need to declare these package variables
  36. with "our":
  37.  
  38.     our($opt_x, $opt_y);
  39.  
  40. For those of you who don't like additional global variables being created, getopt()
  41. and getopts() will also accept a hash reference as an optional second argument. 
  42. Hash keys will be x (where x is the switch name) with key values the value of
  43. the argument or 1 if no argument is specified.
  44.  
  45. To allow programs to process arguments that look like switches, but aren't,
  46. both functions will stop processing switches when they see the argument
  47. C<-->.  The C<--> will be removed from @ARGV.
  48.  
  49. =head1 C<--help> and C<--version>
  50.  
  51. If C<-> is not a recognized switch letter, getopts() supports arguments
  52. C<--help> and C<--version>.  If C<main::HELP_MESSAGE()> and/or
  53. C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
  54. the output file handle, the name of option-processing package, its version,
  55. and the switches string.  If the subroutines are not defined, an attempt is
  56. made to generate intelligent messages; for best results, define $main::VERSION.
  57.  
  58. If embedded documentation (in pod format, see L<perlpod>) is detected
  59. in the script, C<--help> will also show how to access the documentation.
  60.  
  61. Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
  62. isn't true (the default is false), then the messages are printed on STDERR,
  63. and the processing continues after the messages are printed.  This being
  64. the opposite of the standard-conforming behaviour, it is strongly recommended
  65. to set $Getopt::Std::STANDARD_HELP_VERSION to true.
  66.  
  67. One can change the output file handle of the messages by setting
  68. $Getopt::Std::OUTPUT_HELP_VERSION.  One can print the messages of C<--help>
  69. (without the C<Usage:> line) and C<--version> by calling functions help_mess()
  70. and version_mess() with the switches string as an argument.
  71.  
  72. =cut
  73.  
  74. @ISA = qw(Exporter);
  75. @EXPORT = qw(getopt getopts);
  76. $VERSION = '1.04';
  77. # uncomment the next line to disable 1.03-backward compatibility paranoia
  78. # $STANDARD_HELP_VERSION = 1;
  79.  
  80. # Process single-character switches with switch clustering.  Pass one argument
  81. # which is a string containing all switches that take an argument.  For each
  82. # switch found, sets $opt_x (where x is the switch name) to the value of the
  83. # argument, or 1 if no argument.  Switches which take an argument don't care
  84. # whether there is a space between the switch and the argument.
  85.  
  86. # Usage:
  87. #    getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  88.  
  89. sub getopt (;$$) {
  90.     my ($argumentative, $hash) = @_;
  91.     $argumentative = '' if !defined $argumentative;
  92.     my ($first,$rest);
  93.     local $_;
  94.     local @EXPORT;
  95.  
  96.     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  97.     ($first,$rest) = ($1,$2);
  98.     if (/^--$/) {    # early exit if --
  99.         shift @ARGV;
  100.         last;
  101.     }
  102.     if (index($argumentative,$first) >= 0) {
  103.         if ($rest ne '') {
  104.         shift(@ARGV);
  105.         }
  106.         else {
  107.         shift(@ARGV);
  108.         $rest = shift(@ARGV);
  109.         }
  110.         if (ref $hash) {
  111.             $$hash{$first} = $rest;
  112.         }
  113.         else {
  114.             ${"opt_$first"} = $rest;
  115.             push( @EXPORT, "\$opt_$first" );
  116.         }
  117.     }
  118.     else {
  119.         if (ref $hash) {
  120.             $$hash{$first} = 1;
  121.         }
  122.         else {
  123.             ${"opt_$first"} = 1;
  124.             push( @EXPORT, "\$opt_$first" );
  125.         }
  126.         if ($rest ne '') {
  127.         $ARGV[0] = "-$rest";
  128.         }
  129.         else {
  130.         shift(@ARGV);
  131.         }
  132.     }
  133.     }
  134.     unless (ref $hash) { 
  135.     local $Exporter::ExportLevel = 1;
  136.     import Getopt::Std;
  137.     }
  138. }
  139.  
  140. sub output_h () {
  141.   return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
  142.   return \*STDOUT if $STANDARD_HELP_VERSION;
  143.   return \*STDERR;
  144. }
  145.  
  146. sub try_exit () {
  147.     exit 0 if $STANDARD_HELP_VERSION;
  148.     my $p = __PACKAGE__;
  149.     print {output_h()} <<EOM;
  150.   [Now continuing due to backward compatibility and excessive paranoia.
  151.    See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
  152. EOM
  153. }
  154.  
  155. sub version_mess ($;$) {
  156.     my $args = shift;
  157.     my $h = output_h;
  158.     if (@_ and defined &main::VERSION_MESSAGE) {
  159.     main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
  160.     } else {
  161.     my $v = $main::VERSION;
  162.     $v = '[unknown]' unless defined $v;
  163.     my $myv = $VERSION;
  164.     $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
  165.     my $perlv = $];
  166.     $perlv = sprintf "%vd", $^V if $] >= 5.006;
  167.     print $h <<EOH;
  168. $0 version $v calling Getopt::Std::getopts (version $myv),
  169. running under Perl version $perlv.
  170. EOH
  171.     }
  172. }
  173.  
  174. sub help_mess ($;$) {
  175.     my $args = shift;
  176.     my $h = output_h;
  177.     if (@_ and defined &main::HELP_MESSAGE) {
  178.     main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
  179.     } else {
  180.     my (@witharg) = ($args =~ /(\S)\s*:/g);
  181.     my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
  182.     my ($help, $arg) = ('', '');
  183.     if (@witharg) {
  184.         $help .= "\n\tWith arguments: -" . join " -", @witharg;
  185.         $arg = "\nSpace is not required between options and their arguments.";
  186.     }
  187.     if (@rest) {
  188.         $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
  189.     }
  190.     my ($scr) = ($0 =~ m,([^/\\]+)$,);
  191.     print $h <<EOH if @_;            # Let the script override this
  192.  
  193. Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
  194. EOH
  195.     print $h <<EOH;
  196.  
  197. The following single-character options are accepted:$help
  198.  
  199. Options may be merged together.  -- stops processing of options.$arg
  200. EOH
  201.     my $has_pod;
  202.     if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
  203.          and open my $script, '<', $0 ) {
  204.         while (<$script>) {
  205.         $has_pod = 1, last if /^=(pod|head1)/;
  206.         }
  207.     }
  208.     print $h <<EOH if $has_pod;
  209.  
  210. For more details run
  211.     perldoc -F $0
  212. EOH
  213.     }
  214. }
  215.  
  216. # Usage:
  217. #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  218. #            #  side effect.
  219.  
  220. sub getopts ($;$) {
  221.     my ($argumentative, $hash) = @_;
  222.     my (@args,$first,$rest,$exit);
  223.     my $errs = 0;
  224.     local $_;
  225.     local @EXPORT;
  226.  
  227.     @args = split( / */, $argumentative );
  228.     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
  229.     ($first,$rest) = ($1,$2);
  230.     if (/^--$/) {    # early exit if --
  231.         shift @ARGV;
  232.         last;
  233.     }
  234.     my $pos = index($argumentative,$first);
  235.     if ($pos >= 0) {
  236.         if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
  237.         shift(@ARGV);
  238.         if ($rest eq '') {
  239.             ++$errs unless @ARGV;
  240.             $rest = shift(@ARGV);
  241.         }
  242.         if (ref $hash) {
  243.             $$hash{$first} = $rest;
  244.         }
  245.         else {
  246.             ${"opt_$first"} = $rest;
  247.             push( @EXPORT, "\$opt_$first" );
  248.         }
  249.         }
  250.         else {
  251.         if (ref $hash) {
  252.             $$hash{$first} = 1;
  253.         }
  254.         else {
  255.             ${"opt_$first"} = 1;
  256.             push( @EXPORT, "\$opt_$first" );
  257.         }
  258.         if ($rest eq '') {
  259.             shift(@ARGV);
  260.         }
  261.         else {
  262.             $ARGV[0] = "-$rest";
  263.         }
  264.         }
  265.     }
  266.     else {
  267.         if ($first eq '-' and $rest eq 'help') {
  268.         version_mess($argumentative, 'main');
  269.         help_mess($argumentative, 'main');
  270.         try_exit();
  271.         shift(@ARGV);
  272.         next;
  273.         } elsif ($first eq '-' and $rest eq 'version') {
  274.         version_mess($argumentative, 'main');
  275.         try_exit();
  276.         shift(@ARGV);
  277.         next;
  278.         }
  279.         warn "Unknown option: $first\n";
  280.         ++$errs;
  281.         if ($rest ne '') {
  282.         $ARGV[0] = "-$rest";
  283.         }
  284.         else {
  285.         shift(@ARGV);
  286.         }
  287.     }
  288.     }
  289.     unless (ref $hash) { 
  290.     local $Exporter::ExportLevel = 1;
  291.     import Getopt::Std;
  292.     }
  293.     $errs == 0;
  294. }
  295.  
  296. 1;
  297.