Profile of Getopt/Std.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:24:00 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/5.12.3/Getopt/Std.pm
Statements | Executed 6 statements in 31µs

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
0 | 0 | 0 | 0s | 0s | Getopt::Std::::getoptGetopt::Std::getopt
0 | 0 | 0 | 0s | 0s | Getopt::Std::::getoptsGetopt::Std::getopts
0 | 0 | 0 | 0s | 0s | Getopt::Std::::help_messGetopt::Std::help_mess
0 | 0 | 0 | 0s | 0s | Getopt::Std::::output_hGetopt::Std::output_h
0 | 0 | 0 | 0s | 0s | Getopt::Std::::try_exitGetopt::Std::try_exit
0 | 0 | 0 | 0s | 0s | Getopt::Std::::version_messGetopt::Std::version_mess

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Getopt::Std;
2 | 1 | 16µs |  |  | require 5.000;
3 | 1 | 600ns |  |  | 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 | 8µs |  |  | @ISA = qw(Exporter);
74 | 1 | 600ns |  |  | @EXPORT = qw(getopt getopts);
75 | 1 | 300ns |  |  | $VERSION = '1.06';
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 |  |  |  |  | sub getopt (;$$) {
89 |  |  |  |  | my ($argumentative, $hash) = @_;
90 |  |  |  |  | $argumentative = '' if !defined $argumentative;
91 |  |  |  |  | my ($first,$rest);
92 |  |  |  |  | local $_;
93 |  |  |  |  | local @EXPORT;
94 |  |  |  |  |
95 |  |  |  |  | while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
96 |  |  |  |  | ($first,$rest) = ($1,$2);
97 |  |  |  |  | if (/^--$/) { # early exit if --
98 |  |  |  |  | shift @ARGV;
99 |  |  |  |  | last;
100 |  |  |  |  | }
101 |  |  |  |  | if (index($argumentative,$first) >= 0) {
102 |  |  |  |  | if ($rest ne '') {
103 |  |  |  |  | shift(@ARGV);
104 |  |  |  |  | }
105 |  |  |  |  | else {
106 |  |  |  |  | shift(@ARGV);
107 |  |  |  |  | $rest = shift(@ARGV);
108 |  |  |  |  | }
109 |  |  |  |  | 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 |  |  |  |  | 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 | 4µs |  |  | 1;