← 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
StatementsExecuted 6 statements in 31µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sGetopt::Std::::getoptGetopt::Std::getopt
0000s0sGetopt::Std::::getoptsGetopt::Std::getopts
0000s0sGetopt::Std::::help_messGetopt::Std::help_mess
0000s0sGetopt::Std::::output_hGetopt::Std::output_h
0000s0sGetopt::Std::::try_exitGetopt::Std::try_exit
0000s0sGetopt::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
1package Getopt::Std;
2116µsrequire 5.000;
31600nsrequire Exporter;
4
5=head1 NAME
6
7getopt, 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
21The getopt() function processes single-character switches with switch
22clustering. Pass one argument which is a string containing all switches
23that take an argument. For each switch found, sets $opt_x (where x is the
24switch name) to the value of the argument if an argument is expected,
25or 1 otherwise. Switches which take an argument don't care whether
26there is a space between the switch and the argument.
27
28The getopts() function is similar, but you should pass to it the list of all
29switches to be recognized. If unspecified switches are found on the
30command-line, the user will be warned that an unknown option was given.
31The getopts() function returns true unless an invalid option was found.
32
33Note that, if your code is running under the recommended C<use strict
34'vars'> pragma, you will need to declare these package variables
35with "our":
36
37 our($opt_x, $opt_y);
38
39For those of you who don't like additional global variables being created, getopt()
40and getopts() will also accept a hash reference as an optional second argument.
41Hash keys will be x (where x is the switch name) with key values the value of
42the argument or 1 if no argument is specified.
43
44To allow programs to process arguments that look like switches, but aren't,
45both functions will stop processing switches when they see the argument
46C<-->. The C<--> will be removed from @ARGV.
47
48=head1 C<--help> and C<--version>
49
50If C<-> is not a recognized switch letter, getopts() supports arguments
51C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
52C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
53the output file handle, the name of option-processing package, its version,
54and the switches string. If the subroutines are not defined, an attempt is
55made to generate intelligent messages; for best results, define $main::VERSION.
56
57If embedded documentation (in pod format, see L<perlpod>) is detected
58in the script, C<--help> will also show how to access the documentation.
59
60Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
61isn't true (the default is false), then the messages are printed on STDERR,
62and the processing continues after the messages are printed. This being
63the opposite of the standard-conforming behaviour, it is strongly recommended
64to set $Getopt::Std::STANDARD_HELP_VERSION to true.
65
66One 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()
69and version_mess() with the switches string as an argument.
70
71=cut
72
7318µs@ISA = qw(Exporter);
741600ns@EXPORT = qw(getopt getopts);
751300ns$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
88sub 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
139sub output_h () {
140 return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
141 return \*STDOUT if $STANDARD_HELP_VERSION;
142 return \*STDERR;
143}
144
145sub 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.]
151EOM
152}
153
154sub 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),
168running under Perl version $perlv.
169EOH
170 }
171}
172
173sub 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
192Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
193EOH
194 print $h <<EOH;
195
196The following single-character options are accepted:$help
197
198Options may be merged together. -- stops processing of options.$arg
199EOH
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
209For more details run
210 perldoc -F $0
211EOH
212 }
213}
214
215# Usage:
216# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
217# # side effect.
218
219sub 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
29514µs1;