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