Profile of Getopt/Long/Descriptive.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm
Statements | Executed 306 statements in 4.72ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 6.34ms | 7.28ms | Getopt::Long::Descriptive::::BEGIN@8 Getopt::Long::Descriptive::BEGIN@8
1 | 1 | 1 | 1.29ms | 1.70ms | Getopt::Long::Descriptive::::BEGIN@267 Getopt::Long::Descriptive::BEGIN@267
1 | 1 | 1 | 1.03ms | 1.14ms | Getopt::Long::Descriptive::::BEGIN@14 Getopt::Long::Descriptive::BEGIN@14
1 | 1 | 1 | 932µs | 1.02ms | Getopt::Long::Descriptive::::BEGIN@13 Getopt::Long::Descriptive::BEGIN@13
1 | 1 | 1 | 831µs | 4.41ms | Getopt::Long::Descriptive::::BEGIN@10 Getopt::Long::Descriptive::BEGIN@10
2 | 1 | 1 | 246µs | 1.08ms | Getopt::Long::Descriptive::::__ANON__[:470] Getopt::Long::Descriptive::__ANON__[:470]
5 | 1 | 1 | 93µs | 185µs | Getopt::Long::Descriptive::::_validate_with Getopt::Long::Descriptive::_validate_with
2 | 1 | 1 | 44µs | 1.14ms | Getopt::Long::Descriptive::::describe_options Getopt::Long::Descriptive::describe_options
2 | 1 | 1 | 34µs | 43µs | Getopt::Long::Descriptive::::_expand Getopt::Long::Descriptive::_expand
5 | 1 | 1 | 34µs | 52µs | Getopt::Long::Descriptive::::_strip_assignment Getopt::Long::Descriptive::_strip_assignment
1 | 1 | 1 | 17µs | 388µs | Getopt::Long::Descriptive::::BEGIN@268 Getopt::Long::Descriptive::BEGIN@268
2 | 1 | 1 | 17µs | 17µs | Getopt::Long::Descriptive::::_build_describe_options Getopt::Long::Descriptive::_build_describe_options
1 | 1 | 1 | 16µs | 28µs | App::Cmd::ArgProcessor::::BEGIN@1 App::Cmd::ArgProcessor::BEGIN@1
9 | 3 | 1 | 15µs | 15µs | Getopt::Long::Descriptive::::CORE:subst Getopt::Long::Descriptive::CORE:subst (opcode)
4 | 2 | 1 | 15µs | 15µs | Getopt::Long::Descriptive::::CORE:sort Getopt::Long::Descriptive::CORE:sort (opcode)
1 | 1 | 1 | 14µs | 83µs | Getopt::Long::Descriptive::::BEGIN@9 Getopt::Long::Descriptive::BEGIN@9
6 | 2 | 1 | 11µs | 11µs | Getopt::Long::Descriptive::::_munge Getopt::Long::Descriptive::_munge
25 | 5 | 1 | 11µs | 11µs | Getopt::Long::Descriptive::::CORE:match Getopt::Long::Descriptive::CORE:match (opcode)
5 | 1 | 1 | 9µs | 9µs | Getopt::Long::Descriptive::::CORE:regcomp Getopt::Long::Descriptive::CORE:regcomp (opcode)
1 | 1 | 1 | 9µs | 54µs | Getopt::Long::Descriptive::::BEGIN@262 Getopt::Long::Descriptive::BEGIN@262
4 | 2 | 1 | 8µs | 8µs | Getopt::Long::Descriptive::::_nohidden Getopt::Long::Descriptive::_nohidden
1 | 1 | 1 | 7µs | 45µs | Getopt::Long::Descriptive::::BEGIN@6 Getopt::Long::Descriptive::BEGIN@6
1 | 1 | 1 | 6µs | 10µs | App::Cmd::ArgProcessor::::BEGIN@2 App::Cmd::ArgProcessor::BEGIN@2
6 | 1 | 1 | 5µs | 5µs | Getopt::Long::Descriptive::::CORE:substcont Getopt::Long::Descriptive::CORE:substcont (opcode)
1 | 1 | 1 | 5µs | 5µs | Getopt::Long::Descriptive::::BEGIN@7 Getopt::Long::Descriptive::BEGIN@7
1 | 1 | 1 | 4µs | 4µs | Getopt::Long::Descriptive::::BEGIN@11 Getopt::Long::Descriptive::BEGIN@11
3 | 2 | 1 | 3µs | 3µs | Getopt::Long::Descriptive::::prog_name Getopt::Long::Descriptive::prog_name
1 | 1 | 1 | 2µs | 2µs | Getopt::Long::Descriptive::::CORE:qr Getopt::Long::Descriptive::CORE:qr (opcode)
2 | 1 | 1 | 2µs | 2µs | Getopt::Long::Descriptive::::usage_class Getopt::Long::Descriptive::usage_class
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::_PV_Error::::errorGetopt::Long::Descriptive::_PV_Error::error
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::_PV_Error::::throwGetopt::Long::Descriptive::_PV_Error::throw
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::__ANON__[:533] Getopt::Long::Descriptive::__ANON__[:533]
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::__ANON__[:575] Getopt::Long::Descriptive::__ANON__[:575]
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::__ANON__[:597] Getopt::Long::Descriptive::__ANON__[:597]
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::_mk_implies Getopt::Long::Descriptive::_mk_implies
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::_mk_only_one Getopt::Long::Descriptive::_mk_only_one
0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::::_norm_imply Getopt::Long::Descriptive::_norm_imply

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

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 use strict; # 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 use warnings; # 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 use Carp qw(carp croak); # 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 use File::Basename (); # 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 use Getopt::Long 2.33; # 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 use List::Util qw(first); # 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 use Params::Validate 0.97 qw(:all); # 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 use Scalar::Util (); # 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 use Getopt::Long::Descriptive::Opts; # 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 use Getopt::Long::Descriptive::Usage; # 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 sub prog_name { @_ ? ($prog_name = shift) : $prog_name }
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 BEGIN {
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 use Sub::Exporter::Util (); # 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 use Sub::Exporter 0.972 -setup => {
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 sub _nohidden {
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 sub _expand {
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 sub _strip_assignment {
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 sub describe_options {
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 sub usage_class { 'Getopt::Long::Descriptive::Usage' }
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 sub _build_describe_options {
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 sub {
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 sub _munge {
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 sub _validate_with {
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 sub Getopt::Long::Descriptive::CORE:match; # opcode
|  |  |  |  | # 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 sub Getopt::Long::Descriptive::CORE:qr; # opcode
|  |  |  |  | # 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 sub Getopt::Long::Descriptive::CORE:regcomp; # opcode
|  |  |  |  | # 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 sub Getopt::Long::Descriptive::CORE:sort; # opcode
|  |  |  |  | # 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 sub Getopt::Long::Descriptive::CORE:subst; # opcode
|  |  |  |  | # 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 sub Getopt::Long::Descriptive::CORE:substcont; # opcode