| 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 | Getopt::Long::Descriptive::BEGIN@7 |
| 1 | 1 | 1 | 1.17ms | 1.37ms | Getopt::Long::Descriptive::BEGIN@6 |
| 1 | 1 | 1 | 1.04ms | 48.1ms | Getopt::Long::Descriptive::__ANON__[:430] |
| 1 | 1 | 1 | 1.02ms | 14.1ms | Getopt::Long::Descriptive::BEGIN@259 |
| 22 | 1 | 1 | 791µs | 1.98ms | Getopt::Long::Descriptive::_validate_with |
| 1 | 1 | 1 | 682µs | 845µs | Getopt::Long::Descriptive::BEGIN@12 |
| 66 | 2 | 2 | 677µs | 1.01ms | Getopt::Long::Descriptive::_strip_assignment |
| 1 | 1 | 1 | 594µs | 794µs | Getopt::Long::Descriptive::BEGIN@13 |
| 1 | 1 | 1 | 321µs | 1.78ms | Getopt::Long::Descriptive::BEGIN@9 |
| 68 | 3 | 1 | 243µs | 243µs | Getopt::Long::Descriptive::CORE:subst (opcode) |
| 1 | 1 | 1 | 211µs | 369µs | Getopt::Long::Descriptive::_expand |
| 24 | 2 | 1 | 179µs | 179µs | Getopt::Long::Descriptive::_munge |
| 66 | 1 | 1 | 96µs | 96µs | Getopt::Long::Descriptive::CORE:regcomp (opcode) |
| 61 | 3 | 1 | 78µs | 78µs | Getopt::Long::Descriptive::CORE:match (opcode) |
| 1 | 1 | 1 | 55µs | 48.2ms | Getopt::Long::Descriptive::describe_options |
| 2 | 2 | 2 | 29µs | 29µs | Getopt::Long::Descriptive::_build_describe_options |
| 1 | 1 | 1 | 26µs | 792µs | Getopt::Long::Descriptive::BEGIN@260 |
| 1 | 1 | 1 | 24µs | 30µs | MouseX::Getopt::GLD::BEGIN@1 |
| 2 | 2 | 1 | 18µs | 18µs | Getopt::Long::Descriptive::_nohidden |
| 1 | 1 | 1 | 16µs | 104µs | Getopt::Long::Descriptive::BEGIN@8 |
| 1 | 1 | 1 | 15µs | 115µs | Getopt::Long::Descriptive::BEGIN@254 |
| 1 | 1 | 1 | 13µs | 13µs | Getopt::Long::Descriptive::CORE:sort (opcode) |
| 1 | 1 | 1 | 11µs | 66µs | Getopt::Long::Descriptive::BEGIN@5 |
| 1 | 1 | 1 | 11µs | 20µs | MouseX::Getopt::GLD::BEGIN@2.3 |
| 2 | 2 | 1 | 8µs | 8µs | Getopt::Long::Descriptive::prog_name |
| 1 | 1 | 1 | 6µs | 6µs | Getopt::Long::Descriptive::BEGIN@10 |
| 3 | 1 | 1 | 6µs | 6µs | Getopt::Long::Descriptive::CORE:substcont (opcode) |
| 1 | 1 | 1 | 3µs | 3µs | Getopt::Long::Descriptive::usage_class |
| 1 | 1 | 1 | 3µs | 3µs | Getopt::Long::Descriptive::CORE:qr (opcode) |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::__ANON__[:528] |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::__ANON__[:550] |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::_mk_implies |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::_mk_only_one |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::_norm_imply |
| 0 | 0 | 0 | 0s | 0s | MouseX::Getopt::describe_options |
| 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 | 12µs | 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 | 2 | 1.46ms | 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 | 66 | 89µs | my ($self, $str) = @_; | ||
| 302 | |||||
| 303 | 66 | 710µs | 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 | 66 | 267µs | 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 | 1 | 8µ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 | 43µs | 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 | 2 | 3µ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 | 1 | 1µs | my $format = shift; | ||
| 322 | 1 | 3µs | my $arg = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {}; | ||
| 323 | 1 | 700ns | my @opts; | ||
| 324 | |||||
| 325 | # special casing | ||||
| 326 | # wish we had real loop objects | ||||
| 327 | 1 | 1µs | my %method_map; | ||
| 328 | 1 | 9µs | 1 | 369µs | for my $opt (_expand(@_)) { # spent 369µs making 1 call to Getopt::Long::Descriptive::_expand |
| 329 | 22 | 31µs | $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer'; | ||
| 330 | |||||
| 331 | 22 | 23µs | if (ref($opt->{desc}) eq 'ARRAY') { | ||
| 332 | $opt->{constraint}->{one_of} = delete $opt->{desc}; | ||||
| 333 | $opt->{desc} = 'hidden'; | ||||
| 334 | } | ||||
| 335 | 22 | 27µs | if ($HIDDEN{$opt->{desc}}) { | ||
| 336 | $opt->{constraint}->{hidden}++; | ||||
| 337 | } | ||||
| 338 | 22 | 22µs | 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 | 22 | 41µs | push @opts, $opt; | ||
| 355 | } | ||||
| 356 | |||||
| 357 | 1 | 3µs | my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] }; | ||
| 358 | 1 | 1µs | if ($arg->{getopt}) { | ||
| 359 | warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n"; | ||||
| 360 | } | ||||
| 361 | |||||
| 362 | 1 | 2µs | push @go_conf, "bundling" unless grep { /bundling/i } @go_conf; | ||
| 363 | 2 | 12µs | 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 | 19µs | 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 | 178µs | 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 | 22 | 31µs | grep { /^.$/ } | ||
| 375 | 22 | 80µs | 22 | 343µs | map { split /\|/ } # spent 343µs making 22 calls to Getopt::Long::Descriptive::_strip_assignment, avg 16µs/call |
| 376 | 1 | 111µs | 1 | 13µs | map { __PACKAGE__->_strip_assignment($_) } # spent 13µs making 1 call to Getopt::Long::Descriptive::CORE:sort |
| 377 | @specs; | ||||
| 378 | |||||
| 379 | 1 | 91µs | 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 | 10µs | 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 | 1 | 27µs | 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 | 7µs | 1 | 3µs | $str =~ s/\s{2,}/ /g; # spent 3µs making 1 call to Getopt::Long::Descriptive::CORE:subst |
| 392 | |||||
| 393 | 1 | 17µs | 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 | 5µs | 1 | 68µs | Getopt::Long::Configure(@go_conf); # spent 68µs making 1 call to Getopt::Long::Configure |
| 399 | |||||
| 400 | 1 | 1µs | my %return; | ||
| 401 | 1 | 8µs | 1 | 8µs | $usage->die unless GetOptions(\%return, grep { length } @specs); # spent 8µs making 1 call to Getopt::Long::GetOptions |
| 402 | 1 | 4µs | my @given_keys = keys %return; | ||
| 403 | |||||
| 404 | 1 | 7µs | for my $opt (keys %return) { | ||
| 405 | 2 | 10µs | 2 | 20µs | my $newopt = _munge($opt); # spent 20µs making 2 calls to Getopt::Long::Descriptive::_munge, avg 10µs/call |
| 406 | 2 | 3µs | next if $newopt eq $opt; | ||
| 407 | $return{$newopt} = delete $return{$opt}; | ||||
| 408 | } | ||||
| 409 | |||||
| 410 | 1 | 34µs | for my $copt (grep { $_->{constraint} } @opts) { | ||
| 411 | 22 | 31µs | delete $copt->{constraint}->{hidden}; | ||
| 412 | 22 | 28µs | my $name = $copt->{name}; | ||
| 413 | 22 | 101µs | 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 | 22 | 32µs | next unless (defined($new) || exists($return{$name})); | ||
| 421 | 2 | 5µs | $return{$name} = $new; | ||
| 422 | } | ||||
| 423 | |||||
| 424 | my $opt_obj = Getopt::Long::Descriptive::Opts->___new_opt_obj({ | ||||
| 425 | values => { %method_map, %return }, | ||||
| 426 | 1 | 22µs | 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 | 1 | 14µs | return($opt_obj, $usage); | ||
| 430 | } | ||||
| 431 | 2 | 30µs | } | ||
| 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 | 24 | 32µs | my ($opt) = @_; | ||
| 435 | 24 | 20µs | return $opt unless $MungeOptions; | ||
| 436 | 24 | 27µs | $opt = lc($opt); | ||
| 437 | 24 | 29µs | $opt =~ tr/-/_/; | ||
| 438 | 24 | 99µs | 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 | 22 | 796µs | 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 | 22 | 27µs | my $spec = $arg{spec}; | ||
| 450 | 22 | 19µs | my %pvspec; | ||
| 451 | 22 | 68µs | 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 | 22 | 31µs | $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 | 22 | 35µs | if (!defined($arg{params}{$arg{name}}) | ||
| 478 | && $pvspec{default} | ||||
| 479 | && $spec->{implies}) { | ||||
| 480 | |||||
| 481 | $arg{params}{$arg{name}} = delete $pvspec{default}; | ||||
| 482 | } | ||||
| 483 | |||||
| 484 | 22 | 135µs | my %p = eval { | ||
| 485 | validate_with( | ||||
| 486 | 22 | 639µ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 | 22 | 23µs | 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 | 22 | 120µs | 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 |