Commit | Line | Data |
---|---|---|
86530b38 AT |
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 | =cut | |
50 | ||
51 | @ISA = qw(Exporter); | |
52 | @EXPORT = qw(getopt getopts); | |
53 | $VERSION = '1.03'; | |
54 | ||
55 | # Process single-character switches with switch clustering. Pass one argument | |
56 | # which is a string containing all switches that take an argument. For each | |
57 | # switch found, sets $opt_x (where x is the switch name) to the value of the | |
58 | # argument, or 1 if no argument. Switches which take an argument don't care | |
59 | # whether there is a space between the switch and the argument. | |
60 | ||
61 | # Usage: | |
62 | # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. | |
63 | ||
64 | sub getopt (;$$) { | |
65 | my ($argumentative, $hash) = @_; | |
66 | $argumentative = '' if !defined $argumentative; | |
67 | my ($first,$rest); | |
68 | local $_; | |
69 | local @EXPORT; | |
70 | ||
71 | while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { | |
72 | ($first,$rest) = ($1,$2); | |
73 | if (/^--$/) { # early exit if -- | |
74 | shift @ARGV; | |
75 | last; | |
76 | } | |
77 | if (index($argumentative,$first) >= 0) { | |
78 | if ($rest ne '') { | |
79 | shift(@ARGV); | |
80 | } | |
81 | else { | |
82 | shift(@ARGV); | |
83 | $rest = shift(@ARGV); | |
84 | } | |
85 | if (ref $hash) { | |
86 | $$hash{$first} = $rest; | |
87 | } | |
88 | else { | |
89 | ${"opt_$first"} = $rest; | |
90 | push( @EXPORT, "\$opt_$first" ); | |
91 | } | |
92 | } | |
93 | else { | |
94 | if (ref $hash) { | |
95 | $$hash{$first} = 1; | |
96 | } | |
97 | else { | |
98 | ${"opt_$first"} = 1; | |
99 | push( @EXPORT, "\$opt_$first" ); | |
100 | } | |
101 | if ($rest ne '') { | |
102 | $ARGV[0] = "-$rest"; | |
103 | } | |
104 | else { | |
105 | shift(@ARGV); | |
106 | } | |
107 | } | |
108 | } | |
109 | unless (ref $hash) { | |
110 | local $Exporter::ExportLevel = 1; | |
111 | import Getopt::Std; | |
112 | } | |
113 | } | |
114 | ||
115 | # Usage: | |
116 | # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a | |
117 | # # side effect. | |
118 | ||
119 | sub getopts ($;$) { | |
120 | my ($argumentative, $hash) = @_; | |
121 | my (@args,$first,$rest); | |
122 | my $errs = 0; | |
123 | local $_; | |
124 | local @EXPORT; | |
125 | ||
126 | @args = split( / */, $argumentative ); | |
127 | while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { | |
128 | ($first,$rest) = ($1,$2); | |
129 | if (/^--$/) { # early exit if -- | |
130 | shift @ARGV; | |
131 | last; | |
132 | } | |
133 | $pos = index($argumentative,$first); | |
134 | if ($pos >= 0) { | |
135 | if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { | |
136 | shift(@ARGV); | |
137 | if ($rest eq '') { | |
138 | ++$errs unless @ARGV; | |
139 | $rest = shift(@ARGV); | |
140 | } | |
141 | if (ref $hash) { | |
142 | $$hash{$first} = $rest; | |
143 | } | |
144 | else { | |
145 | ${"opt_$first"} = $rest; | |
146 | push( @EXPORT, "\$opt_$first" ); | |
147 | } | |
148 | } | |
149 | else { | |
150 | if (ref $hash) { | |
151 | $$hash{$first} = 1; | |
152 | } | |
153 | else { | |
154 | ${"opt_$first"} = 1; | |
155 | push( @EXPORT, "\$opt_$first" ); | |
156 | } | |
157 | if ($rest eq '') { | |
158 | shift(@ARGV); | |
159 | } | |
160 | else { | |
161 | $ARGV[0] = "-$rest"; | |
162 | } | |
163 | } | |
164 | } | |
165 | else { | |
166 | warn "Unknown option: $first\n"; | |
167 | ++$errs; | |
168 | if ($rest ne '') { | |
169 | $ARGV[0] = "-$rest"; | |
170 | } | |
171 | else { | |
172 | shift(@ARGV); | |
173 | } | |
174 | } | |
175 | } | |
176 | unless (ref $hash) { | |
177 | local $Exporter::ExportLevel = 1; | |
178 | import Getopt::Std; | |
179 | } | |
180 | $errs == 0; | |
181 | } | |
182 | ||
183 | 1; |