This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
allow '--' to terminate argument processing (suggested by
[perl5.git] / lib / Getopt / Std.pm
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;