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