This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.000
[perl5.git] / lib / Getopt / Std.pm
1 package Getopt::Std;
2 require 5.000;
3 require Exporter;
4
5 @ISA = qw(Exporter);
6 @EXPORT = qw(getopt getopts);
7
8 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
9
10 # Process single-character switches with switch clustering.  Pass one argument
11 # which is a string containing all switches that take an argument.  For each
12 # switch found, sets $opt_x (where x is the switch name) to the value of the
13 # argument, or 1 if no argument.  Switches which take an argument don't care
14 # whether there is a space between the switch and the argument.
15
16 # Usage:
17 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
18
19 sub getopt {
20     local($argumentative) = @_;
21     local($_,$first,$rest);
22     local $Exporter::ExportLevel;
23
24     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
25         ($first,$rest) = ($1,$2);
26         if (index($argumentative,$first) >= 0) {
27             if ($rest ne '') {
28                 shift(@ARGV);
29             }
30             else {
31                 shift(@ARGV);
32                 $rest = shift(@ARGV);
33             }
34             eval "\$opt_$first = \$rest;";
35             push( @EXPORT, "\$opt_$first" );
36         }
37         else {
38             eval "\$opt_$first = 1;";
39             push( @EXPORT, "\$opt_$first" );
40             if ($rest ne '') {
41                 $ARGV[0] = "-$rest";
42             }
43             else {
44                 shift(@ARGV);
45             }
46         }
47     }
48     $Exporter::ExportLevel++;
49     import Getopt::Std;
50 }
51
52 # Usage:
53 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
54 #                       #  side effect.
55
56 sub getopts {
57     local($argumentative) = @_;
58     local(@args,$_,$first,$rest);
59     local($errs) = 0;
60     local $Exporter::ExportLevel;
61
62     @args = split( / */, $argumentative );
63     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
64         ($first,$rest) = ($1,$2);
65         $pos = index($argumentative,$first);
66         if($pos >= 0) {
67             if($args[$pos+1] eq ':') {
68                 shift(@ARGV);
69                 if($rest eq '') {
70                     ++$errs unless @ARGV;
71                     $rest = shift(@ARGV);
72                 }
73                 eval "\$opt_$first = \$rest;";
74                 push( @EXPORT, "\$opt_$first" );
75             }
76             else {
77                 eval "\$opt_$first = 1";
78                 push( @EXPORT, "\$opt_$first" );
79                 if($rest eq '') {
80                     shift(@ARGV);
81                 }
82                 else {
83                     $ARGV[0] = "-$rest";
84                 }
85             }
86         }
87         else {
88             print STDERR "Unknown option: $first\n";
89             ++$errs;
90             if($rest ne '') {
91                 $ARGV[0] = "-$rest";
92             }
93             else {
94                 shift(@ARGV);
95             }
96         }
97     }
98     $Exporter::ExportLevel++;
99     import Getopt::Std;
100     $errs == 0;
101 }
102
103 1;
104