Filename | /usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm |
Statements | Executed 306 statements in 4.72ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 6.34ms | 7.28ms | BEGIN@8 | Getopt::Long::Descriptive::
1 | 1 | 1 | 1.29ms | 1.70ms | BEGIN@267 | Getopt::Long::Descriptive::
1 | 1 | 1 | 1.03ms | 1.14ms | BEGIN@14 | Getopt::Long::Descriptive::
1 | 1 | 1 | 932µs | 1.02ms | BEGIN@13 | Getopt::Long::Descriptive::
1 | 1 | 1 | 831µs | 4.41ms | BEGIN@10 | Getopt::Long::Descriptive::
2 | 1 | 1 | 246µs | 1.08ms | __ANON__[:470] | Getopt::Long::Descriptive::
5 | 1 | 1 | 93µs | 185µs | _validate_with | Getopt::Long::Descriptive::
2 | 1 | 1 | 44µs | 1.14ms | describe_options | Getopt::Long::Descriptive::
2 | 1 | 1 | 34µs | 43µs | _expand | Getopt::Long::Descriptive::
5 | 1 | 1 | 34µs | 52µs | _strip_assignment | Getopt::Long::Descriptive::
1 | 1 | 1 | 17µs | 388µs | BEGIN@268 | Getopt::Long::Descriptive::
2 | 1 | 1 | 17µs | 17µs | _build_describe_options | Getopt::Long::Descriptive::
1 | 1 | 1 | 16µs | 28µs | BEGIN@1 | App::Cmd::ArgProcessor::
9 | 3 | 1 | 15µs | 15µs | CORE:subst (opcode) | Getopt::Long::Descriptive::
4 | 2 | 1 | 15µs | 15µs | CORE:sort (opcode) | Getopt::Long::Descriptive::
1 | 1 | 1 | 14µs | 83µs | BEGIN@9 | Getopt::Long::Descriptive::
6 | 2 | 1 | 11µs | 11µs | _munge | Getopt::Long::Descriptive::
25 | 5 | 1 | 11µs | 11µs | CORE:match (opcode) | Getopt::Long::Descriptive::
5 | 1 | 1 | 9µs | 9µs | CORE:regcomp (opcode) | Getopt::Long::Descriptive::
1 | 1 | 1 | 9µs | 54µs | BEGIN@262 | Getopt::Long::Descriptive::
4 | 2 | 1 | 8µs | 8µs | _nohidden | Getopt::Long::Descriptive::
1 | 1 | 1 | 7µs | 45µs | BEGIN@6 | Getopt::Long::Descriptive::
1 | 1 | 1 | 6µs | 10µs | BEGIN@2 | App::Cmd::ArgProcessor::
6 | 1 | 1 | 5µs | 5µs | CORE:substcont (opcode) | Getopt::Long::Descriptive::
1 | 1 | 1 | 5µs | 5µs | BEGIN@7 | Getopt::Long::Descriptive::
1 | 1 | 1 | 4µs | 4µs | BEGIN@11 | Getopt::Long::Descriptive::
3 | 2 | 1 | 3µs | 3µs | prog_name | Getopt::Long::Descriptive::
1 | 1 | 1 | 2µs | 2µs | CORE:qr (opcode) | Getopt::Long::Descriptive::
2 | 1 | 1 | 2µs | 2µs | usage_class | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | error | Getopt::Long::Descriptive::_PV_Error::
0 | 0 | 0 | 0s | 0s | throw | Getopt::Long::Descriptive::_PV_Error::
0 | 0 | 0 | 0s | 0s | __ANON__[:533] | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | __ANON__[:575] | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | __ANON__[:597] | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | _mk_implies | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | _mk_only_one | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | _norm_imply | Getopt::Long::Descriptive::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | 2 | 26µs | 2 | 40µs | # spent 28µs (16+12) within App::Cmd::ArgProcessor::BEGIN@1 which was called:
# once (16µs+12µs) by App::Cmd::ArgProcessor::_process_args at line 1 # spent 28µs making 1 call to App::Cmd::ArgProcessor::BEGIN@1
# spent 12µs making 1 call to strict::import |
2 | 2 | 38µs | 2 | 14µs | # spent 10µs (6+4) within App::Cmd::ArgProcessor::BEGIN@2 which was called:
# once (6µs+4µs) by App::Cmd::ArgProcessor::_process_args at line 2 # spent 10µs making 1 call to App::Cmd::ArgProcessor::BEGIN@2
# spent 4µs making 1 call to warnings::import |
3 | package Getopt::Long::Descriptive; | ||||
4 | # ABSTRACT: Getopt::Long, but simpler and more powerful | ||||
5 | 1 | 400ns | $Getopt::Long::Descriptive::VERSION = '0.097'; | ||
6 | 2 | 24µs | 2 | 83µs | # spent 45µs (7+38) within Getopt::Long::Descriptive::BEGIN@6 which was called:
# once (7µs+38µs) by App::Cmd::ArgProcessor::_process_args at line 6 # spent 45µs making 1 call to Getopt::Long::Descriptive::BEGIN@6
# spent 38µs making 1 call to Exporter::import |
7 | 2 | 23µs | 1 | 5µs | # spent 5µs within Getopt::Long::Descriptive::BEGIN@7 which was called:
# once (5µs+0s) by App::Cmd::ArgProcessor::_process_args at line 7 # spent 5µs making 1 call to Getopt::Long::Descriptive::BEGIN@7 |
8 | 3 | 116µs | 3 | 7.45ms | # spent 7.28ms (6.34+944µs) within Getopt::Long::Descriptive::BEGIN@8 which was called:
# once (6.34ms+944µs) by App::Cmd::ArgProcessor::_process_args at line 8 # spent 7.28ms making 1 call to Getopt::Long::Descriptive::BEGIN@8
# spent 148µs making 1 call to Getopt::Long::import
# spent 19µs making 1 call to Getopt::Long::VERSION |
9 | 2 | 30µs | 2 | 91µs | # spent 83µs (14+69) within Getopt::Long::Descriptive::BEGIN@9 which was called:
# once (14µs+69µs) by App::Cmd::ArgProcessor::_process_args at line 9 # spent 83µs making 1 call to Getopt::Long::Descriptive::BEGIN@9
# spent 8µs making 1 call to List::Util::import |
10 | 3 | 589µs | 3 | 4.61ms | # spent 4.41ms (831µs+3.58) within Getopt::Long::Descriptive::BEGIN@10 which was called:
# once (831µs+3.58ms) by App::Cmd::ArgProcessor::_process_args at line 10 # spent 4.41ms making 1 call to Getopt::Long::Descriptive::BEGIN@10
# spent 186µs making 1 call to Exporter::import
# spent 10µs making 1 call to UNIVERSAL::VERSION |
11 | 2 | 19µs | 1 | 4µs | # spent 4µs within Getopt::Long::Descriptive::BEGIN@11 which was called:
# once (4µs+0s) by App::Cmd::ArgProcessor::_process_args at line 11 # spent 4µs making 1 call to Getopt::Long::Descriptive::BEGIN@11 |
12 | |||||
13 | 2 | 449µs | 1 | 1.02ms | # spent 1.02ms (932µs+90µs) within Getopt::Long::Descriptive::BEGIN@13 which was called:
# once (932µs+90µs) by App::Cmd::ArgProcessor::_process_args at line 13 # spent 1.02ms making 1 call to Getopt::Long::Descriptive::BEGIN@13 |
14 | 2 | 575µs | 1 | 1.14ms | # spent 1.14ms (1.03+116µs) within Getopt::Long::Descriptive::BEGIN@14 which was called:
# once (1.03ms+116µs) by App::Cmd::ArgProcessor::_process_args at line 14 # spent 1.14ms making 1 call to Getopt::Long::Descriptive::BEGIN@14 |
15 | |||||
16 | # =head1 SYNOPSIS | ||||
17 | # | ||||
18 | # use Getopt::Long::Descriptive; | ||||
19 | # | ||||
20 | # my ($opt, $usage) = describe_options( | ||||
21 | # 'my-program %o <some-arg>', | ||||
22 | # [ 'server|s=s', "the server to connect to", { required => 1 } ], | ||||
23 | # [ 'port|p=i', "the port to connect to", { default => 79 } ], | ||||
24 | # [], | ||||
25 | # [ 'verbose|v', "print extra stuff" ], | ||||
26 | # [ 'help', "print usage message and exit" ], | ||||
27 | # ); | ||||
28 | # | ||||
29 | # print($usage->text), exit if $opt->help; | ||||
30 | # | ||||
31 | # Client->connect( $opt->server, $opt->port ); | ||||
32 | # | ||||
33 | # print "Connected!\n" if $opt->verbose; | ||||
34 | # | ||||
35 | # ...and running C<my-program --help> will produce: | ||||
36 | # | ||||
37 | # my-program [-psv] [long options...] <some-arg> | ||||
38 | # -s --server the server to connect to | ||||
39 | # -p --port the port to connect to | ||||
40 | # | ||||
41 | # -v --verbose print extra stuff | ||||
42 | # --help print usage message and exit | ||||
43 | # | ||||
44 | # =head1 DESCRIPTION | ||||
45 | # | ||||
46 | # Getopt::Long::Descriptive is yet another Getopt library. It's built atop | ||||
47 | # Getopt::Long, and gets a lot of its features, but tries to avoid making you | ||||
48 | # think about its huge array of options. | ||||
49 | # | ||||
50 | # It also provides usage (help) messages, data validation, and a few other useful | ||||
51 | # features. | ||||
52 | # | ||||
53 | # =head1 FUNCTIONS | ||||
54 | # | ||||
55 | # Getopt::Long::Descriptive only exports one routine by default: | ||||
56 | # C<describe_options>. All GLD's exports are exported by L<Sub::Exporter>. | ||||
57 | # | ||||
58 | # =head2 describe_options | ||||
59 | # | ||||
60 | # my ($opt, $usage) = describe_options($usage_desc, @opt_spec, \%arg); | ||||
61 | # | ||||
62 | # This routine inspects C<@ARGV> for options that match the supplied spec. If all | ||||
63 | # the options are valid then it returns the options given and an object for | ||||
64 | # generating usage messages; if not then it dies with an explanation of what was | ||||
65 | # wrong and a usage message. | ||||
66 | # | ||||
67 | # The C<$opt> object will be a dynamically-generated subclass of | ||||
68 | # L<Getopt::Long::Descriptive::Opts>. In brief, each of the options in | ||||
69 | # C<@opt_spec> becomes an accessor method on the object, using the first-given | ||||
70 | # name, with dashes converted to underscores. For more information, see the | ||||
71 | # documentation for the Opts class. | ||||
72 | # | ||||
73 | # The C<$usage> object will be a L<Getopt::Long::Descriptive::Usage> object, | ||||
74 | # which provides a C<text> method to get the text of the usage message and C<die> | ||||
75 | # to die with it. For more methods and options, consults the documentation for | ||||
76 | # the Usage class. | ||||
77 | # | ||||
78 | # =head3 $usage_desc | ||||
79 | # | ||||
80 | # The C<$usage_desc> parameter to C<describe_options> is a C<sprintf>-like string | ||||
81 | # that is used in generating the first line of the usage message. It's a | ||||
82 | # one-line summary of how the command is to be invoked. A typical usage | ||||
83 | # description might be: | ||||
84 | # | ||||
85 | # $usage_desc = "%c %o <source> <desc>"; | ||||
86 | # | ||||
87 | # C<%c> will be replaced with what Getopt::Long::Descriptive thinks is the | ||||
88 | # program name (it's computed from C<$0>, see L</prog_name>). | ||||
89 | # | ||||
90 | # C<%o> will be replaced with a list of the short options, as well as the text | ||||
91 | # "[long options...]" if any have been defined. | ||||
92 | # | ||||
93 | # The rest of the usage description can be used to summarize what arguments are | ||||
94 | # expected to follow the program's options, and is entirely free-form. | ||||
95 | # | ||||
96 | # Literal C<%> characters will need to be written as C<%%>, just like with | ||||
97 | # C<sprintf>. | ||||
98 | # | ||||
99 | # =head3 @opt_spec | ||||
100 | # | ||||
101 | # The C<@opt_spec> part of the args to C<describe_options> is used to configure | ||||
102 | # option parsing and to produce the usage message. Each entry in the list is an | ||||
103 | # arrayref describing one option, like this: | ||||
104 | # | ||||
105 | # @opt_spec = ( | ||||
106 | # [ "verbose|V" => "be noisy" ], | ||||
107 | # [ "logfile=s" => "file to log to" ], | ||||
108 | # ); | ||||
109 | # | ||||
110 | # The first value in the arrayref is a Getopt::Long-style option specification. | ||||
111 | # In brief, they work like this: each one is a pipe-delimited list of names, | ||||
112 | # optionally followed by a type declaration. Type declarations are '=x' or ':x', | ||||
113 | # where C<=> means a value is required and C<:> means it is optional. I<x> may | ||||
114 | # be 's' to indicate a string is required, 'i' for an integer, or 'f' for a | ||||
115 | # number with a fractional part. The type spec may end in C<@> to indicate that | ||||
116 | # the option may appear multiple times. | ||||
117 | # | ||||
118 | # For more information on how these work, see the L<Getopt::Long> documentation. | ||||
119 | # | ||||
120 | # The first name given should be the canonical name, as it will be used as the | ||||
121 | # accessor method on the C<$opt> object. Dashes in the name will be converted to | ||||
122 | # underscores, and all letters will be lowercased. For this reason, all options | ||||
123 | # should generally have a long-form name. | ||||
124 | # | ||||
125 | # The second value in the arrayref is a description of the option, for use in the | ||||
126 | # usage message. | ||||
127 | # | ||||
128 | # =head4 Special Option Specifications | ||||
129 | # | ||||
130 | # If the option specification (arrayref) is empty, it will have no effect other | ||||
131 | # than causing a blank line to appear in the usage message. | ||||
132 | # | ||||
133 | # If the option specification contains only one element, it will be printed in | ||||
134 | # the usage message with no other effect. | ||||
135 | # | ||||
136 | # If the option specification contains a third element, it adds extra constraints | ||||
137 | # or modifiers to the interpretation and validation of the value. These are the | ||||
138 | # keys that may be present in that hashref, and how they behave: | ||||
139 | # | ||||
140 | # =over 4 | ||||
141 | # | ||||
142 | # =item implies | ||||
143 | # | ||||
144 | # implies => 'bar' | ||||
145 | # implies => [qw(foo bar)] | ||||
146 | # implies => { foo => 1, bar => 2 } | ||||
147 | # | ||||
148 | # If option I<A> has an "implies" entry, then if I<A> is given, other options | ||||
149 | # will be enabled. The value may be a single option to set, an arrayref of | ||||
150 | # options to set, or a hashref of options to set to specific values. | ||||
151 | # | ||||
152 | # =item required | ||||
153 | # | ||||
154 | # required => 1 | ||||
155 | # | ||||
156 | # If an option is required, failure to provide the option will result in | ||||
157 | # C<describe_options> printing the usage message and exiting. | ||||
158 | # | ||||
159 | # =item hidden | ||||
160 | # | ||||
161 | # hidden => 1 | ||||
162 | # | ||||
163 | # This option will not show up in the usage text. | ||||
164 | # | ||||
165 | # You can achieve the same behavior by using the string "hidden" for the option's | ||||
166 | # description. | ||||
167 | # | ||||
168 | # =item one_of | ||||
169 | # | ||||
170 | # one_of => \@subopt_specs | ||||
171 | # | ||||
172 | # This is useful for a group of options that are related. Each option | ||||
173 | # spec is added to the list for normal parsing and validation. | ||||
174 | # | ||||
175 | # Your option name will end up with a value of the name of the | ||||
176 | # option that was chosen. For example, given the following spec: | ||||
177 | # | ||||
178 | # [ "mode" => hidden => { one_of => [ | ||||
179 | # [ "get|g" => "get the value" ], | ||||
180 | # [ "set|s" => "set the value" ], | ||||
181 | # [ "delete" => "delete it" ], | ||||
182 | # ] } ], | ||||
183 | # | ||||
184 | # No usage text for 'mode' will be displayed, but text for get, set, and delete | ||||
185 | # will be displayed. | ||||
186 | # | ||||
187 | # If more than one of get, set, or delete is given, an error will be thrown. | ||||
188 | # | ||||
189 | # So, given the C<@opt_spec> above, and an C<@ARGV> of C<('--get')>, the | ||||
190 | # following would be true: | ||||
191 | # | ||||
192 | # $opt->get == 1; | ||||
193 | # | ||||
194 | # $opt->mode eq 'get'; | ||||
195 | # | ||||
196 | # B<Note>: C<get> would not be set if C<mode> defaulted to 'get' and no arguments | ||||
197 | # were passed in. | ||||
198 | # | ||||
199 | # Even though the option sub-specs for C<one_of> are meant to be 'first | ||||
200 | # class' specs, some options don't make sense with them, e.g. C<required>. | ||||
201 | # | ||||
202 | # As a further shorthand, you may specify C<one_of> options using this form: | ||||
203 | # | ||||
204 | # [ mode => \@option_specs, \%constraints ] | ||||
205 | # | ||||
206 | # | ||||
207 | # =item shortcircuit | ||||
208 | # | ||||
209 | # shortcircuit => 1 | ||||
210 | # | ||||
211 | # If this option is present no other options will be returned. Other | ||||
212 | # options present will be checked for proper types, but I<not> for | ||||
213 | # constraints. This provides a way of specifying C<--help> style options. | ||||
214 | # | ||||
215 | # =item Params::Validate | ||||
216 | # | ||||
217 | # In addition, any constraint understood by Params::Validate may be used. | ||||
218 | # | ||||
219 | # For example, to accept positive integers: | ||||
220 | # | ||||
221 | # [ 'max-iterations=i', "maximum number of iterations", | ||||
222 | # { callbacks => { positive => sub { shift() > 0 } } } ], | ||||
223 | # | ||||
224 | # (Internally, all constraints are translated into Params::Validate options or | ||||
225 | # callbacks.) | ||||
226 | # | ||||
227 | # =back | ||||
228 | # | ||||
229 | # =head3 %arg | ||||
230 | # | ||||
231 | # The C<%arg> to C<describe_options> is optional. If the last parameter is a | ||||
232 | # hashref, it contains extra arguments to modify the way C<describe_options> | ||||
233 | # works. Valid arguments are: | ||||
234 | # | ||||
235 | # getopt_conf - an arrayref of strings, passed to Getopt::Long::Configure | ||||
236 | # show_defaults - a boolean which controls whether an option's default | ||||
237 | # value (if applicable) is shown as part of the usage message | ||||
238 | # (for backward compatibility this defaults to false) | ||||
239 | # | ||||
240 | # =head2 prog_name | ||||
241 | # | ||||
242 | # This routine, exported on demand, returns the basename of C<$0>, grabbed at | ||||
243 | # compile-time. You can override this guess by calling C<prog_name($string)> | ||||
244 | # yourself. | ||||
245 | # | ||||
246 | # =head1 OTHER EXPORTS | ||||
247 | # | ||||
248 | # =head2 C<-types> | ||||
249 | # | ||||
250 | # Any of the Params::Validate type constants (C<SCALAR>, etc.) can be imported as | ||||
251 | # well. You can get all of them at once by importing C<-types>. | ||||
252 | # | ||||
253 | # =head2 C<-all> | ||||
254 | # | ||||
255 | # This import group will import C<-type>, C<describe_options>, and C<prog_name>. | ||||
256 | # | ||||
257 | # =cut | ||||
258 | |||||
259 | 1 | 100ns | my $prog_name; | ||
260 | 3 | 8µs | # spent 3µs within Getopt::Long::Descriptive::prog_name which was called 3 times, avg 1µs/call:
# 2 times (2µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 404, avg 1µs/call
# once (1µs+0s) by Getopt::Long::Descriptive::BEGIN@262 at line 264 | ||
261 | |||||
262 | # spent 54µs (9+45) within Getopt::Long::Descriptive::BEGIN@262 which was called:
# once (9µs+45µs) by App::Cmd::ArgProcessor::_process_args at line 265 | ||||
263 | # grab this before someone decides to change it | ||||
264 | 1 | 4µs | 2 | 45µs | prog_name(File::Basename::basename($0)); # spent 44µs making 1 call to File::Basename::basename
# spent 1µs making 1 call to Getopt::Long::Descriptive::prog_name |
265 | 1 | 19µs | 1 | 54µs | } # spent 54µs making 1 call to Getopt::Long::Descriptive::BEGIN@262 |
266 | |||||
267 | 2 | 515µs | 1 | 1.70ms | # spent 1.70ms (1.29+409µs) within Getopt::Long::Descriptive::BEGIN@267 which was called:
# once (1.29ms+409µs) by App::Cmd::ArgProcessor::_process_args at line 267 # spent 1.70ms making 1 call to Getopt::Long::Descriptive::BEGIN@267 |
268 | # spent 388µs (17+370) within Getopt::Long::Descriptive::BEGIN@268 which was called:
# once (17µs+370µs) by App::Cmd::ArgProcessor::_process_args at line 278 | ||||
269 | exports => [ | ||||
270 | describe_options => \'_build_describe_options', | ||||
271 | q(prog_name), | ||||
272 | 1 | 8µs | 1 | 361µs | @{ $Params::Validate::EXPORT_TAGS{types} } # spent 361µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:337] |
273 | ], | ||||
274 | groups => [ | ||||
275 | default => [ qw(describe_options) ], | ||||
276 | types => $Params::Validate::EXPORT_TAGS{types}, | ||||
277 | ], | ||||
278 | 2 | 1.64ms | 2 | 397µs | }; # spent 388µs making 1 call to Getopt::Long::Descriptive::BEGIN@268
# spent 9µs making 1 call to UNIVERSAL::VERSION |
279 | |||||
280 | 1 | 4µs | my %CONSTRAINT = ( | ||
281 | implies => \&_mk_implies, | ||||
282 | required => { optional => 0 }, | ||||
283 | only_one => \&_mk_only_one, | ||||
284 | ); | ||||
285 | |||||
286 | 1 | 100ns | our $MungeOptions = 1; | ||
287 | |||||
288 | # spent 8µs within Getopt::Long::Descriptive::_nohidden which was called 4 times, avg 2µs/call:
# 2 times (5µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 392, avg 2µs/call
# 2 times (4µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 421, avg 2µs/call | ||||
289 | 4 | 17µs | return grep { ! $_->{constraint}->{hidden} } @_; | ||
290 | } | ||||
291 | |||||
292 | # spent 43µs (34+9) within Getopt::Long::Descriptive::_expand which was called 2 times, avg 22µs/call:
# 2 times (34µs+9µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 336, avg 22µs/call | ||||
293 | 7 | 31µs | 5 | 9µs | return map { {( # spent 9µs making 5 calls to Getopt::Long::Descriptive::_munge, avg 2µs/call |
294 | spec => $_->[0] || '', | ||||
295 | desc => @$_ > 1 ? $_->[1] : 'spacer', | ||||
296 | constraint => $_->[2] || {}, | ||||
297 | |||||
298 | # if @$_ is 0 then we got [], a spacer | ||||
299 | name => @$_ ? _munge((split /[:=|!+]/, $_->[0] || '')[0]) : '', | ||||
300 | )} } @_; | ||||
301 | } | ||||
302 | |||||
303 | 1 | 400ns | my %HIDDEN = ( | ||
304 | hidden => 1, | ||||
305 | ); | ||||
306 | |||||
307 | 1 | 9µs | 1 | 2µs | my $SPEC_RE = qr{(?:[:=][\d\w\+]+[%@]?({\d*,\d*})?|[!+])$}; # spent 2µs making 1 call to Getopt::Long::Descriptive::CORE:qr |
308 | # spent 52µs (34+19) within Getopt::Long::Descriptive::_strip_assignment which was called 5 times, avg 10µs/call:
# 5 times (34µs+19µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 398, avg 10µs/call | ||||
309 | 5 | 2µs | my ($self, $str) = @_; | ||
310 | |||||
311 | 5 | 36µs | 10 | 19µs | (my $copy = $str) =~ s{$SPEC_RE}{}; # spent 10µs making 5 calls to Getopt::Long::Descriptive::CORE:subst, avg 2µs/call
# spent 9µs making 5 calls to Getopt::Long::Descriptive::CORE:regcomp, avg 2µs/call |
312 | |||||
313 | 5 | 20µs | return $copy; | ||
314 | } | ||||
315 | |||||
316 | # This is here only to deal with people who were calling this fully-qualified | ||||
317 | # without importing. Sucks to them! -- rjbs, 2009-08-21 | ||||
318 | # spent 1.14ms (44µs+1.10) within Getopt::Long::Descriptive::describe_options which was called 2 times, avg 570µs/call:
# 2 times (44µs+1.10ms) by App::Cmd::ArgProcessor::_process_args at line 15 of App/Cmd/ArgProcessor.pm, avg 570µs/call | ||||
319 | 2 | 4µs | 2 | 17µs | my $sub = __PACKAGE__->_build_describe_options(describe_options => {} => {}); # spent 17µs making 2 calls to Getopt::Long::Descriptive::_build_describe_options, avg 8µs/call |
320 | 2 | 36µs | 2 | 1.08ms | $sub->(@_); # spent 1.08ms making 2 calls to Getopt::Long::Descriptive::__ANON__[Getopt/Long/Descriptive.pm:470], avg 540µs/call |
321 | } | ||||
322 | |||||
323 | 2 | 6µs | # spent 2µs within Getopt::Long::Descriptive::usage_class which was called 2 times, avg 1µs/call:
# 2 times (2µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 421, avg 1µs/call | ||
324 | |||||
325 | # spent 17µs within Getopt::Long::Descriptive::_build_describe_options which was called 2 times, avg 8µs/call:
# 2 times (17µs+0s) by Getopt::Long::Descriptive::describe_options at line 319, avg 8µs/call | ||||
326 | 2 | 700ns | my ($class) = @_; | ||
327 | |||||
328 | # spent 1.08ms (246µs+834µs) within Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] which was called 2 times, avg 540µs/call:
# 2 times (246µs+834µs) by Getopt::Long::Descriptive::describe_options at line 320, avg 540µs/call | ||||
329 | 2 | 900ns | my $format = shift; | ||
330 | 2 | 2µs | my $arg = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {}; | ||
331 | 2 | 200ns | my @opts; | ||
332 | |||||
333 | # special casing | ||||
334 | # wish we had real loop objects | ||||
335 | 2 | 300ns | my %method_map; | ||
336 | 2 | 3µs | 2 | 43µs | for my $opt (_expand(@_)) { # spent 43µs making 2 calls to Getopt::Long::Descriptive::_expand, avg 22µs/call |
337 | 5 | 4µs | $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer'; | ||
338 | |||||
339 | 5 | 700ns | if (ref($opt->{desc}) eq 'ARRAY') { | ||
340 | $opt->{constraint}->{one_of} = delete $opt->{desc}; | ||||
341 | $opt->{desc} = 'hidden'; | ||||
342 | } | ||||
343 | 5 | 1µs | if ($HIDDEN{$opt->{desc}}) { | ||
344 | $opt->{constraint}->{hidden}++; | ||||
345 | } | ||||
346 | 5 | 800ns | if ($opt->{constraint}->{one_of}) { | ||
347 | for my $one_opt (_expand( | ||||
348 | @{delete $opt->{constraint}->{one_of}} | ||||
349 | )) { | ||||
350 | $one_opt->{constraint}->{implies} | ||||
351 | ->{$opt->{name}} = $one_opt->{name}; | ||||
352 | for my $wipe (qw(required default)) { | ||||
353 | if ($one_opt->{constraint}->{$wipe}) { | ||||
354 | carp "'$wipe' constraint does not make sense in sub-option"; | ||||
355 | delete $one_opt->{constraint}->{$wipe}; | ||||
356 | } | ||||
357 | } | ||||
358 | $one_opt->{constraint}->{one_of} = $opt->{name}; | ||||
359 | push @opts, $one_opt; | ||||
360 | } | ||||
361 | } | ||||
362 | 5 | 600ns | if ($opt->{constraint}{shortcircuit} | ||
363 | && exists $opt->{constraint}{default} | ||||
364 | ) { | ||||
365 | carp('option "' . $opt->{name} . q[": 'default' does not make sense for shortcircuit options]); | ||||
366 | } | ||||
367 | 5 | 3µs | push @opts, $opt; | ||
368 | |||||
369 | } | ||||
370 | |||||
371 | 2 | 4µs | my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] }; | ||
372 | 2 | 300ns | if ($arg->{getopt}) { | ||
373 | warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n"; | ||||
374 | } | ||||
375 | |||||
376 | 3 | 7µs | 1 | 1µs | push @go_conf, "bundling" unless grep { /bundling/i } @go_conf; # spent 1µs making 1 call to Getopt::Long::Descriptive::CORE:match |
377 | 5 | 10µs | 3 | 1µs | push @go_conf, "no_auto_help" unless grep { /no_auto_help/i } @go_conf; # spent 1µs making 3 calls to Getopt::Long::Descriptive::CORE:match, avg 333ns/call |
378 | 5 | 9µs | 5 | 500ns | push @go_conf, "no_ignore_case" # spent 500ns making 5 calls to Getopt::Long::Descriptive::CORE:match, avg 100ns/call |
379 | 2 | 2µs | unless grep { /no_ignore_case/i } @go_conf; | ||
380 | |||||
381 | # not entirely sure that all of this (until the Usage->new) shouldn't be | ||||
382 | # moved into Usage -- rjbs, 2009-08-19 | ||||
383 | |||||
384 | # all specs including hidden | ||||
385 | my @getopt_specs = | ||||
386 | map { $_->{spec} } | ||||
387 | 2 | 7µs | grep { $_->{desc} ne 'spacer' } | ||
388 | @opts; | ||||
389 | |||||
390 | my @specs = | ||||
391 | map { $_->{spec} } | ||||
392 | 2 | 6µs | 2 | 5µs | grep { $_->{desc} ne 'spacer' } # spent 5µs making 2 calls to Getopt::Long::Descriptive::_nohidden, avg 2µs/call |
393 | _nohidden(@opts); | ||||
394 | |||||
395 | my $short = join q{}, | ||||
396 | 11 | 20µs | 11 | 4µs | sort { lc $a cmp lc $b or $a cmp $b } # spent 4µs making 11 calls to Getopt::Long::Descriptive::CORE:match, avg 355ns/call |
397 | 5 | 3µs | grep { /^.$/ } | ||
398 | 5 | 5µs | 5 | 52µs | map { split /\|/ } # spent 52µs making 5 calls to Getopt::Long::Descriptive::_strip_assignment, avg 10µs/call |
399 | 2 | 24µs | 2 | 10µs | map { __PACKAGE__->_strip_assignment($_) } # spent 10µs making 2 calls to Getopt::Long::Descriptive::CORE:sort, avg 5µs/call |
400 | @specs; | ||||
401 | |||||
402 | 2 | 13µs | 5 | 5µs | my $long = grep /\b[^|]{2,}/, @specs; # spent 5µs making 5 calls to Getopt::Long::Descriptive::CORE:match, avg 940ns/call |
403 | |||||
404 | 2 | 9µs | 2 | 2µs | my %replace = ( # spent 2µs making 2 calls to Getopt::Long::Descriptive::prog_name, avg 1µs/call |
405 | "%" => "%", | ||||
406 | "c" => prog_name, | ||||
407 | "o" => join(q{ }, | ||||
408 | ($short ? "[-$short]" : ()), | ||||
409 | ($long ? "[long options...]" : ()) | ||||
410 | ), | ||||
411 | ); | ||||
412 | |||||
413 | 2 | 26µs | 8 | 8µs | (my $str = $format) =~ s<%(.)>< # spent 5µs making 6 calls to Getopt::Long::Descriptive::CORE:substcont, avg 817ns/call
# spent 4µs making 2 calls to Getopt::Long::Descriptive::CORE:subst, avg 2µs/call |
414 | defined $replace{$1} | ||||
415 | ? $replace{$1} | ||||
416 | : Carp::croak("unknown sequence %$1 in first argument to describe_options") | ||||
417 | >ge; | ||||
418 | |||||
419 | 2 | 5µs | 2 | 2µs | $str =~ s/[\x20\t]{2,}/ /g; # spent 2µs making 2 calls to Getopt::Long::Descriptive::CORE:subst, avg 1µs/call |
420 | |||||
421 | 2 | 11µs | 6 | 19µs | my $usage = $class->usage_class->new({ # spent 13µs making 2 calls to Getopt::Long::Descriptive::Usage::new, avg 7µs/call
# spent 4µs making 2 calls to Getopt::Long::Descriptive::_nohidden, avg 2µs/call
# spent 2µs making 2 calls to Getopt::Long::Descriptive::usage_class, avg 1µs/call |
422 | options => [ _nohidden(@opts) ], | ||||
423 | leader_text => $str, | ||||
424 | show_defaults => $arg->{show_defaults}, | ||||
425 | }); | ||||
426 | |||||
427 | 2 | 3µs | 2 | 71µs | Getopt::Long::Configure(@go_conf); # spent 71µs making 2 calls to Getopt::Long::Configure, avg 35µs/call |
428 | |||||
429 | 2 | 200ns | my %return; | ||
430 | 2 | 5µs | 2 | 8µs | $usage->die unless GetOptions(\%return, grep { length } @getopt_specs); # spent 8µs making 2 calls to Getopt::Long::GetOptions, avg 4µs/call |
431 | 2 | 2µs | my @given_keys = keys %return; | ||
432 | |||||
433 | 2 | 2µs | for my $opt (keys %return) { | ||
434 | 1 | 1µs | 1 | 2µs | my $newopt = _munge($opt); # spent 2µs making 1 call to Getopt::Long::Descriptive::_munge |
435 | 1 | 400ns | next if $newopt eq $opt; | ||
436 | $return{$newopt} = delete $return{$opt}; | ||||
437 | } | ||||
438 | |||||
439 | # ensure that shortcircuit options are handled first | ||||
440 | 2 | 13µs | 2 | 5µs | for my $copt ( # spent 5µs making 2 calls to Getopt::Long::Descriptive::CORE:sort, avg 2µs/call |
441 | sort { ($b->{constraint}{shortcircuit} || 0) | ||||
442 | <=> ($a->{constraint}{shortcircuit} || 0) | ||||
443 | } grep { $_->{constraint} } @opts | ||||
444 | ) { | ||||
445 | 5 | 2µs | delete $copt->{constraint}->{hidden}; | ||
446 | 5 | 1µs | my $is_shortcircuit = delete $copt->{constraint}{shortcircuit}; | ||
447 | 5 | 1µs | my $name = $copt->{name}; | ||
448 | 5 | 6µs | 5 | 185µs | my $new = _validate_with( # spent 185µs making 5 calls to Getopt::Long::Descriptive::_validate_with, avg 37µs/call |
449 | name => $name, | ||||
450 | params => \%return, | ||||
451 | spec => $copt->{constraint}, | ||||
452 | opts => \@opts, | ||||
453 | usage => $usage, | ||||
454 | ); | ||||
455 | 5 | 2µs | next unless (defined($new) || exists($return{$name})); | ||
456 | 1 | 300ns | $return{$name} = $new; | ||
457 | |||||
458 | 1 | 400ns | if ($is_shortcircuit) { | ||
459 | %return = ($name => $return{$name}); | ||||
460 | last; | ||||
461 | } | ||||
462 | } | ||||
463 | |||||
464 | my $opt_obj = Getopt::Long::Descriptive::Opts->___new_opt_obj({ | ||||
465 | values => { %method_map, %return }, | ||||
466 | 2 | 9µs | 2 | 113µs | given => { map {; $_ => 1 } @given_keys }, # spent 113µs making 2 calls to Getopt::Long::Descriptive::Opts::___new_opt_obj, avg 56µs/call |
467 | }); | ||||
468 | |||||
469 | 2 | 10µs | return($opt_obj, $usage); | ||
470 | } | ||||
471 | 2 | 19µs | } | ||
472 | |||||
473 | # spent 11µs within Getopt::Long::Descriptive::_munge which was called 6 times, avg 2µs/call:
# 5 times (9µs+0s) by Getopt::Long::Descriptive::_expand at line 293, avg 2µs/call
# once (2µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 434 | ||||
474 | 6 | 2µs | my ($opt) = @_; | ||
475 | 6 | 500ns | return $opt unless $MungeOptions; | ||
476 | 6 | 2µs | $opt = lc($opt); | ||
477 | 6 | 2µs | $opt =~ tr/-/_/; | ||
478 | 6 | 13µs | return $opt; | ||
479 | } | ||||
480 | |||||
481 | # spent 185µs (93+92) within Getopt::Long::Descriptive::_validate_with which was called 5 times, avg 37µs/call:
# 5 times (93µs+92µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 448, avg 37µs/call | ||||
482 | 5 | 85µs | 5 | 54µs | my (%arg) = validate(@_, { # spent 54µs making 5 calls to Params::Validate::XS::validate, avg 11µs/call |
483 | name => 1, | ||||
484 | params => 1, | ||||
485 | spec => 1, | ||||
486 | opts => 1, | ||||
487 | usage => 1, | ||||
488 | }); | ||||
489 | 5 | 2µs | my $spec = $arg{spec}; | ||
490 | 5 | 500ns | my %pvspec; | ||
491 | 5 | 5µs | for my $ct (keys %{$spec}) { | ||
492 | if ($CONSTRAINT{$ct} and ref $CONSTRAINT{$ct} eq 'CODE') { | ||||
493 | $pvspec{callbacks} ||= {}; | ||||
494 | $pvspec{callbacks} = { | ||||
495 | %{$pvspec{callbacks}}, | ||||
496 | $CONSTRAINT{$ct}->( | ||||
497 | $arg{name}, | ||||
498 | $spec->{$ct}, | ||||
499 | $arg{params}, | ||||
500 | $arg{opts}, | ||||
501 | ), | ||||
502 | }; | ||||
503 | } else { | ||||
504 | %pvspec = ( | ||||
505 | %pvspec, | ||||
506 | $CONSTRAINT{$ct} ? %{$CONSTRAINT{$ct}} : ($ct => $spec->{$ct}), | ||||
507 | ); | ||||
508 | } | ||||
509 | } | ||||
510 | |||||
511 | 5 | 2µs | $pvspec{optional} = 1 unless exists $pvspec{optional}; | ||
512 | |||||
513 | # we need to implement 'default' by ourselves sometimes | ||||
514 | # because otherwise the implies won't be checked/executed | ||||
515 | # XXX this should be more generic -- we'll probably want | ||||
516 | # other callbacks to always run, too | ||||
517 | 5 | 3µs | if (!defined($arg{params}{$arg{name}}) | ||
518 | && $pvspec{default} | ||||
519 | && $spec->{implies}) { | ||||
520 | |||||
521 | $arg{params}{$arg{name}} = delete $pvspec{default}; | ||||
522 | } | ||||
523 | |||||
524 | 5 | 400ns | my %p; | ||
525 | 5 | 2µs | my $ok = eval { | ||
526 | %p = validate_with( | ||||
527 | params => [ %{$arg{params}} ], | ||||
528 | spec => { $arg{name} => \%pvspec }, | ||||
529 | allow_extra => 1, | ||||
530 | on_fail => sub { | ||||
531 | my $fail_msg = shift; | ||||
532 | Getopt::Long::Descriptive::_PV_Error->throw($fail_msg); | ||||
533 | }, | ||||
534 | 5 | 76µs | 5 | 38µs | ); # spent 38µs making 5 calls to Params::Validate::XS::validate_with, avg 8µs/call |
535 | 5 | 1µs | 1; | ||
536 | }; | ||||
537 | |||||
538 | 5 | 600ns | if (! $ok) { | ||
539 | my $error = $@; | ||||
540 | if ( | ||||
541 | Scalar::Util::blessed($error) | ||||
542 | && $error->isa('Getopt::Long::Descriptive::_PV_Error') | ||||
543 | ) { | ||||
544 | $arg{usage}->die({ pre_text => $error->error . "\n" }); | ||||
545 | } | ||||
546 | |||||
547 | die $@; | ||||
548 | } | ||||
549 | |||||
550 | 5 | 15µs | return $p{$arg{name}}; | ||
551 | } | ||||
552 | |||||
553 | # scalar: single option = true | ||||
554 | # arrayref: multiple options = true | ||||
555 | # hashref: single/multiple options = given values | ||||
556 | sub _norm_imply { | ||||
557 | my ($what) = @_; | ||||
558 | |||||
559 | return { $what => 1 } unless my $ref = ref $what; | ||||
560 | |||||
561 | return $what if $ref eq 'HASH'; | ||||
562 | return { map { $_ => 1 } @$what } if $ref eq 'ARRAY'; | ||||
563 | |||||
564 | die "can't imply: $what"; | ||||
565 | } | ||||
566 | |||||
567 | sub _mk_implies { | ||||
568 | my $name = shift; | ||||
569 | my $what = _norm_imply(shift); | ||||
570 | my $param = shift; | ||||
571 | my $opts = shift; | ||||
572 | |||||
573 | for my $implied (keys %$what) { | ||||
574 | die("option specification for $name implies nonexistent option $implied\n") | ||||
575 | unless first { $_->{name} eq $implied } @$opts | ||||
576 | } | ||||
577 | |||||
578 | my $whatstr = join(q{, }, map { "$_=$what->{$_}" } keys %$what); | ||||
579 | |||||
580 | return "$name implies $whatstr" => sub { | ||||
581 | my ($pv_val) = shift; | ||||
582 | |||||
583 | # negatable options will be 0 here, which is ok. | ||||
584 | return 1 unless defined $pv_val; | ||||
585 | |||||
586 | while (my ($key, $val) = each %$what) { | ||||
587 | if (exists $param->{$key} and $param->{$key} ne $val) { | ||||
588 | die( | ||||
589 | "option specification for $name implies that $key should be " | ||||
590 | . "set to '$val', but it is '$param->{$key}' already\n" | ||||
591 | ); | ||||
592 | } | ||||
593 | $param->{$key} = $val; | ||||
594 | } | ||||
595 | |||||
596 | return 1; | ||||
597 | }; | ||||
598 | } | ||||
599 | |||||
600 | sub _mk_only_one { | ||||
601 | die "unimplemented"; | ||||
602 | } | ||||
603 | |||||
604 | { | ||||
605 | 1 | 500ns | package | ||
606 | Getopt::Long::Descriptive::_PV_Error; | ||||
607 | sub error { $_[0]->{error} } | ||||
608 | sub throw { | ||||
609 | my ($class, $error_msg) = @_; | ||||
610 | my $self = { error => $error_msg }; | ||||
611 | bless $self, $class; | ||||
612 | die $self; | ||||
613 | } | ||||
614 | } | ||||
615 | |||||
616 | # =head1 CUSTOMIZING | ||||
617 | # | ||||
618 | # Getopt::Long::Descriptive uses L<Sub::Exporter|Sub::Exporter> to build and | ||||
619 | # export the C<describe_options> routine. By writing a new class that extends | ||||
620 | # Getopt::Long::Descriptive, the behavior of the constructed C<describe_options> | ||||
621 | # routine can be changed. | ||||
622 | # | ||||
623 | # The following methods can be overridden: | ||||
624 | # | ||||
625 | # =head2 usage_class | ||||
626 | # | ||||
627 | # my $class = Getopt::Long::Descriptive->usage_class; | ||||
628 | # | ||||
629 | # This returns the class to be used for constructing a Usage object, and defaults | ||||
630 | # to Getopt::Long::Descriptive::Usage. | ||||
631 | # | ||||
632 | # =head1 SEE ALSO | ||||
633 | # | ||||
634 | # =for :list | ||||
635 | # * L<Getopt::Long> | ||||
636 | # * L<Params::Validate> | ||||
637 | # | ||||
638 | # =cut | ||||
639 | |||||
640 | 1 | 6µs | 1; # End of Getopt::Long::Descriptive | ||
641 | |||||
642 | __END__ | ||||
# spent 11µs within Getopt::Long::Descriptive::CORE:match which was called 25 times, avg 448ns/call:
# 11 times (4µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 396, avg 355ns/call
# 5 times (5µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 402, avg 940ns/call
# 5 times (500ns+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 378, avg 100ns/call
# 3 times (1µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 377, avg 333ns/call
# once (1µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 376 | |||||
# spent 2µs within Getopt::Long::Descriptive::CORE:qr which was called:
# once (2µs+0s) by App::Cmd::ArgProcessor::_process_args at line 307 | |||||
# spent 9µs within Getopt::Long::Descriptive::CORE:regcomp which was called 5 times, avg 2µs/call:
# 5 times (9µs+0s) by Getopt::Long::Descriptive::_strip_assignment at line 311, avg 2µs/call | |||||
# spent 15µs within Getopt::Long::Descriptive::CORE:sort which was called 4 times, avg 4µs/call:
# 2 times (10µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 399, avg 5µs/call
# 2 times (5µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 440, avg 2µs/call | |||||
# spent 15µs within Getopt::Long::Descriptive::CORE:subst which was called 9 times, avg 2µs/call:
# 5 times (10µs+0s) by Getopt::Long::Descriptive::_strip_assignment at line 311, avg 2µs/call
# 2 times (4µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 413, avg 2µs/call
# 2 times (2µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 419, avg 1µs/call | |||||
# spent 5µs within Getopt::Long::Descriptive::CORE:substcont which was called 6 times, avg 817ns/call:
# 6 times (5µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 413, avg 817ns/call |