home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Getopt / Std.pm < prev   
Text File  |  2000-01-25  |  4KB  |  177 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() functions 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, or 1 if no argument.  Switches
  27. which take an argument don't care whether there is a space between the
  28. switch and the argument.
  29.  
  30. Note that, if your code is running under the recommended C<use strict
  31. 'vars'> pragma, you will need to declare these package variables
  32. with "our":
  33.  
  34.     our($opt_foo, $opt_bar);
  35.  
  36. For those of you who don't like additional global variables being created, getopt()
  37. and getopts() will also accept a hash reference as an optional second argument. 
  38. Hash keys will be x (where x is the switch name) with key values the value of
  39. the argument or 1 if no argument is specified.
  40.  
  41. To allow programs to process arguments that look like switches, but aren't,
  42. both functions will stop processing switches when they see the argument
  43. C<-->.  The C<--> will be removed from @ARGV.
  44.  
  45. =cut
  46.  
  47. @ISA = qw(Exporter);
  48. @EXPORT = qw(getopt getopts);
  49. $VERSION = '1.02';
  50.  
  51. # Process single-character switches with switch clustering.  Pass one argument
  52. # which is a string containing all switches that take an argument.  For each
  53. # switch found, sets $opt_x (where x is the switch name) to the value of the
  54. # argument, or 1 if no argument.  Switches which take an argument don't care
  55. # whether there is a space between the switch and the argument.
  56.  
  57. # Usage:
  58. #    getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  59.  
  60. sub getopt ($;$) {
  61.     local($argumentative, $hash) = @_;
  62.     local($_,$first,$rest);
  63.     local @EXPORT;
  64.  
  65.     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  66.     ($first,$rest) = ($1,$2);
  67.     if (/^--$/) {    # early exit if --
  68.         shift @ARGV;
  69.         last;
  70.     }
  71.     if (index($argumentative,$first) >= 0) {
  72.         if ($rest ne '') {
  73.         shift(@ARGV);
  74.         }
  75.         else {
  76.         shift(@ARGV);
  77.         $rest = shift(@ARGV);
  78.         }
  79.         if (ref $hash) {
  80.             $$hash{$first} = $rest;
  81.         }
  82.         else {
  83.             ${"opt_$first"} = $rest;
  84.             push( @EXPORT, "\$opt_$first" );
  85.         }
  86.     }
  87.     else {
  88.         if (ref $hash) {
  89.             $$hash{$first} = 1;
  90.         }
  91.         else {
  92.             ${"opt_$first"} = 1;
  93.             push( @EXPORT, "\$opt_$first" );
  94.         }
  95.         if ($rest ne '') {
  96.         $ARGV[0] = "-$rest";
  97.         }
  98.         else {
  99.         shift(@ARGV);
  100.         }
  101.     }
  102.     }
  103.     unless (ref $hash) { 
  104.     local $Exporter::ExportLevel = 1;
  105.     import Getopt::Std;
  106.     }
  107. }
  108.  
  109. # Usage:
  110. #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  111. #            #  side effect.
  112.  
  113. sub getopts ($;$) {
  114.     local($argumentative, $hash) = @_;
  115.     local(@args,$_,$first,$rest);
  116.     local($errs) = 0;
  117.     local @EXPORT;
  118.  
  119.     @args = split( / */, $argumentative );
  120.     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  121.     ($first,$rest) = ($1,$2);
  122.     if (/^--$/) {    # early exit if --
  123.         shift @ARGV;
  124.         last;
  125.     }
  126.     $pos = index($argumentative,$first);
  127.     if ($pos >= 0) {
  128.         if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
  129.         shift(@ARGV);
  130.         if ($rest eq '') {
  131.             ++$errs unless @ARGV;
  132.             $rest = shift(@ARGV);
  133.         }
  134.         if (ref $hash) {
  135.             $$hash{$first} = $rest;
  136.         }
  137.         else {
  138.             ${"opt_$first"} = $rest;
  139.             push( @EXPORT, "\$opt_$first" );
  140.         }
  141.         }
  142.         else {
  143.         if (ref $hash) {
  144.             $$hash{$first} = 1;
  145.         }
  146.         else {
  147.             ${"opt_$first"} = 1;
  148.             push( @EXPORT, "\$opt_$first" );
  149.         }
  150.         if ($rest eq '') {
  151.             shift(@ARGV);
  152.         }
  153.         else {
  154.             $ARGV[0] = "-$rest";
  155.         }
  156.         }
  157.     }
  158.     else {
  159.         warn "Unknown option: $first\n";
  160.         ++$errs;
  161.         if ($rest ne '') {
  162.         $ARGV[0] = "-$rest";
  163.         }
  164.         else {
  165.         shift(@ARGV);
  166.         }
  167.     }
  168.     }
  169.     unless (ref $hash) { 
  170.     local $Exporter::ExportLevel = 1;
  171.     import Getopt::Std;
  172.     }
  173.     $errs == 0;
  174. }
  175.  
  176. 1;
  177.