← 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
StatementsExecuted 306 statements in 4.72ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1116.34ms7.28msGetopt::Long::Descriptive::::BEGIN@8 Getopt::Long::Descriptive::BEGIN@8
1111.29ms1.70msGetopt::Long::Descriptive::::BEGIN@267 Getopt::Long::Descriptive::BEGIN@267
1111.03ms1.14msGetopt::Long::Descriptive::::BEGIN@14 Getopt::Long::Descriptive::BEGIN@14
111932µs1.02msGetopt::Long::Descriptive::::BEGIN@13 Getopt::Long::Descriptive::BEGIN@13
111831µs4.41msGetopt::Long::Descriptive::::BEGIN@10 Getopt::Long::Descriptive::BEGIN@10
211246µs1.08msGetopt::Long::Descriptive::::__ANON__[:470] Getopt::Long::Descriptive::__ANON__[:470]
51193µs185µsGetopt::Long::Descriptive::::_validate_with Getopt::Long::Descriptive::_validate_with
21144µs1.14msGetopt::Long::Descriptive::::describe_options Getopt::Long::Descriptive::describe_options
21134µs43µsGetopt::Long::Descriptive::::_expand Getopt::Long::Descriptive::_expand
51134µs52µsGetopt::Long::Descriptive::::_strip_assignment Getopt::Long::Descriptive::_strip_assignment
11117µs388µsGetopt::Long::Descriptive::::BEGIN@268 Getopt::Long::Descriptive::BEGIN@268
21117µs17µsGetopt::Long::Descriptive::::_build_describe_options Getopt::Long::Descriptive::_build_describe_options
11116µs28µsApp::Cmd::ArgProcessor::::BEGIN@1 App::Cmd::ArgProcessor::BEGIN@1
93115µs15µsGetopt::Long::Descriptive::::CORE:subst Getopt::Long::Descriptive::CORE:subst (opcode)
42115µs15µsGetopt::Long::Descriptive::::CORE:sort Getopt::Long::Descriptive::CORE:sort (opcode)
11114µs83µsGetopt::Long::Descriptive::::BEGIN@9 Getopt::Long::Descriptive::BEGIN@9
62111µs11µsGetopt::Long::Descriptive::::_munge Getopt::Long::Descriptive::_munge
255111µs11µsGetopt::Long::Descriptive::::CORE:match Getopt::Long::Descriptive::CORE:match (opcode)
5119µs9µsGetopt::Long::Descriptive::::CORE:regcomp Getopt::Long::Descriptive::CORE:regcomp (opcode)
1119µs54µsGetopt::Long::Descriptive::::BEGIN@262 Getopt::Long::Descriptive::BEGIN@262
4218µs8µsGetopt::Long::Descriptive::::_nohidden Getopt::Long::Descriptive::_nohidden
1117µs45µsGetopt::Long::Descriptive::::BEGIN@6 Getopt::Long::Descriptive::BEGIN@6
1116µs10µsApp::Cmd::ArgProcessor::::BEGIN@2 App::Cmd::ArgProcessor::BEGIN@2
6115µs5µsGetopt::Long::Descriptive::::CORE:substcont Getopt::Long::Descriptive::CORE:substcont (opcode)
1115µs5µsGetopt::Long::Descriptive::::BEGIN@7 Getopt::Long::Descriptive::BEGIN@7
1114µs4µsGetopt::Long::Descriptive::::BEGIN@11 Getopt::Long::Descriptive::BEGIN@11
3213µs3µsGetopt::Long::Descriptive::::prog_name Getopt::Long::Descriptive::prog_name
1112µs2µsGetopt::Long::Descriptive::::CORE:qr Getopt::Long::Descriptive::CORE:qr (opcode)
2112µs2µsGetopt::Long::Descriptive::::usage_class Getopt::Long::Descriptive::usage_class
0000s0sGetopt::Long::Descriptive::_PV_Error::::errorGetopt::Long::Descriptive::_PV_Error::error
0000s0sGetopt::Long::Descriptive::_PV_Error::::throwGetopt::Long::Descriptive::_PV_Error::throw
0000s0sGetopt::Long::Descriptive::::__ANON__[:533] Getopt::Long::Descriptive::__ANON__[:533]
0000s0sGetopt::Long::Descriptive::::__ANON__[:575] Getopt::Long::Descriptive::__ANON__[:575]
0000s0sGetopt::Long::Descriptive::::__ANON__[:597] Getopt::Long::Descriptive::__ANON__[:597]
0000s0sGetopt::Long::Descriptive::::_mk_implies Getopt::Long::Descriptive::_mk_implies
0000s0sGetopt::Long::Descriptive::::_mk_only_one Getopt::Long::Descriptive::_mk_only_one
0000s0sGetopt::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
1226µs240µ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
2238µs214µ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
3package Getopt::Long::Descriptive;
4# ABSTRACT: Getopt::Long, but simpler and more powerful
51400ns$Getopt::Long::Descriptive::VERSION = '0.097';
6224µs283µ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
7223µs15µ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
83116µs37.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
9230µs291µ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
103589µs34.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
11219µs14µ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
132449µs11.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
142575µs11.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
2591100nsmy $prog_name;
26038µ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
26414µs245µ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
265119µs154µs}
# spent 54µs making 1 call to Getopt::Long::Descriptive::BEGIN@262
266
2672515µs11.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),
27218µs1361µ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 ],
27821.64ms2397µs};
# spent 388µs making 1 call to Getopt::Long::Descriptive::BEGIN@268 # spent 9µs making 1 call to UNIVERSAL::VERSION
279
28014µsmy %CONSTRAINT = (
281 implies => \&_mk_implies,
282 required => { optional => 0 },
283 only_one => \&_mk_only_one,
284);
285
2861100nsour $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 {
289417µ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 {
293731µs59µ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
3031400nsmy %HIDDEN = (
304 hidden => 1,
305);
306
30719µs12µsmy $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 {
30952µs my ($self, $str) = @_;
310
311536µs1019µ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
313520µ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 {
31924µs217µ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
320236µs21.08ms $sub->(@_);
# spent 1.08ms making 2 calls to Getopt::Long::Descriptive::__ANON__[Getopt/Long/Descriptive.pm:470], avg 540µs/call
321}
322
32326µ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 {
3262700ns 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 {
3292900ns my $format = shift;
33022µs my $arg = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};
3312200ns my @opts;
332
333 # special casing
334 # wish we had real loop objects
3352300ns my %method_map;
33623µs243µs for my $opt (_expand(@_)) {
# spent 43µs making 2 calls to Getopt::Long::Descriptive::_expand, avg 22µs/call
33754µs $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer';
338
3395700ns if (ref($opt->{desc}) eq 'ARRAY') {
340 $opt->{constraint}->{one_of} = delete $opt->{desc};
341 $opt->{desc} = 'hidden';
342 }
34351µs if ($HIDDEN{$opt->{desc}}) {
344 $opt->{constraint}->{hidden}++;
345 }
3465800ns 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 }
3625600ns 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 }
36753µs push @opts, $opt;
368
369 }
370
37124µs my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
3722300ns if ($arg->{getopt}) {
373 warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
374 }
375
37637µs11µs push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
# spent 1µs making 1 call to Getopt::Long::Descriptive::CORE:match
377510µs31µ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
37859µs5500ns push @go_conf, "no_ignore_case"
# spent 500ns making 5 calls to Getopt::Long::Descriptive::CORE:match, avg 100ns/call
37922µ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} }
38727µs grep { $_->{desc} ne 'spacer' }
388 @opts;
389
390 my @specs =
391 map { $_->{spec} }
39226µs25µ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{},
3961120µs114µ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
39753µs grep { /^.$/ }
39855µs552µs map { split /\|/ }
# spent 52µs making 5 calls to Getopt::Long::Descriptive::_strip_assignment, avg 10µs/call
399224µs210µs map { __PACKAGE__->_strip_assignment($_) }
# spent 10µs making 2 calls to Getopt::Long::Descriptive::CORE:sort, avg 5µs/call
400 @specs;
401
402213µs55µs my $long = grep /\b[^|]{2,}/, @specs;
# spent 5µs making 5 calls to Getopt::Long::Descriptive::CORE:match, avg 940ns/call
403
40429µs22µ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
413226µs88µ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
41925µs22µs $str =~ s/[\x20\t]{2,}/ /g;
# spent 2µs making 2 calls to Getopt::Long::Descriptive::CORE:subst, avg 1µs/call
420
421211µs619µ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
42723µs271µs Getopt::Long::Configure(@go_conf);
# spent 71µs making 2 calls to Getopt::Long::Configure, avg 35µs/call
428
4292200ns my %return;
43025µs28µs $usage->die unless GetOptions(\%return, grep { length } @getopt_specs);
# spent 8µs making 2 calls to Getopt::Long::GetOptions, avg 4µs/call
43122µs my @given_keys = keys %return;
432
43322µs for my $opt (keys %return) {
43411µs12µs my $newopt = _munge($opt);
# spent 2µs making 1 call to Getopt::Long::Descriptive::_munge
4351400ns next if $newopt eq $opt;
436 $return{$newopt} = delete $return{$opt};
437 }
438
439 # ensure that shortcircuit options are handled first
440213µs25µ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 ) {
44552µs delete $copt->{constraint}->{hidden};
44651µs my $is_shortcircuit = delete $copt->{constraint}{shortcircuit};
44751µs my $name = $copt->{name};
44856µs5185µ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 );
45552µs next unless (defined($new) || exists($return{$name}));
4561300ns $return{$name} = $new;
457
4581400ns 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 },
46629µs2113µ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
469210µs return($opt_obj, $usage);
470 }
471219µ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 {
47462µs my ($opt) = @_;
4756500ns return $opt unless $MungeOptions;
47662µs $opt = lc($opt);
47762µs $opt =~ tr/-/_/;
478613µ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 {
482585µs554µ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 });
48952µs my $spec = $arg{spec};
4905500ns my %pvspec;
49155µ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
51152µ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
51753µs if (!defined($arg{params}{$arg{name}})
518 && $pvspec{default}
519 && $spec->{implies}) {
520
521 $arg{params}{$arg{name}} = delete $pvspec{default};
522 }
523
5245400ns my %p;
52552µ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 },
534576µs538µs );
# spent 38µs making 5 calls to Params::Validate::XS::validate_with, avg 8µs/call
53551µs 1;
536 };
537
5385600ns 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
550515µs return $p{$arg{name}};
551}
552
553# scalar: single option = true
554# arrayref: multiple options = true
555# hashref: single/multiple options = given values
556sub _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
567sub _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
600sub _mk_only_one {
601 die "unimplemented";
602}
603
604{
6051500ns 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
64016µs1; # 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