← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 20:36:06 2020
Reported on Wed Feb 12 21:42:25 2020

Filename/usr/share/perl/5.28/Getopt/Long.pm
StatementsExecuted 1322 statements in 9.58ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
2711358µs436µsGetopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
111235µs1.00msGetopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
311194µs266µsGetopt::Long::::FindOption Getopt::Long::FindOption
17591135µs135µsGetopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
984191µs91µsGetopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
11125µs25µsmain::::BEGIN@13 main::BEGIN@13
11124µs46µsGetopt::Long::::BEGIN@232 Getopt::Long::BEGIN@232
11116µs60µsGetopt::Long::CallBack::::BEGIN@1568Getopt::Long::CallBack::BEGIN@1568
21113µs13µsGetopt::Long::::CORE:sort Getopt::Long::CORE:sort (opcode)
11113µs188µsGetopt::Long::::import Getopt::Long::import
11112µs17µsmain::::BEGIN@15 main::BEGIN@15
11112µs77µsGetopt::Long::::BEGIN@220 Getopt::Long::BEGIN@220
1119µs39µsGetopt::Long::::BEGIN@20 Getopt::Long::BEGIN@20
1119µs43µsmain::::BEGIN@16 main::BEGIN@16
1118µs8µsGetopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
1118µs22µsGetopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1117µs58µsGetopt::Long::::BEGIN@259 Getopt::Long::BEGIN@259
1116µs19µsGetopt::Long::::BEGIN@23 Getopt::Long::BEGIN@23
1116µs33µsGetopt::Long::::BEGIN@234 Getopt::Long::BEGIN@234
1116µs25µsGetopt::Long::::BEGIN@237 Getopt::Long::BEGIN@237
1115µs29µsGetopt::Long::::BEGIN@235 Getopt::Long::BEGIN@235
1115µs74µsGetopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1115µs29µsGetopt::Long::::BEGIN@230 Getopt::Long::BEGIN@230
1115µs42µsGetopt::Long::::BEGIN@47 Getopt::Long::BEGIN@47
1115µs26µsGetopt::Long::::BEGIN@238 Getopt::Long::BEGIN@238
1115µs26µsGetopt::Long::::BEGIN@240 Getopt::Long::BEGIN@240
1115µs53µsGetopt::Long::::BEGIN@49 Getopt::Long::BEGIN@49
1115µs46µsGetopt::Long::::BEGIN@52 Getopt::Long::BEGIN@52
1115µs31µsGetopt::Long::::BEGIN@249 Getopt::Long::BEGIN@249
1115µs33µsGetopt::Long::::BEGIN@27 Getopt::Long::BEGIN@27
1115µs5µsGetopt::Long::::BEGIN@38 Getopt::Long::BEGIN@38
1114µs25µsGetopt::Long::::BEGIN@241 Getopt::Long::BEGIN@241
1114µs26µsGetopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1114µs25µsGetopt::Long::::BEGIN@248 Getopt::Long::BEGIN@248
1114µs4µsGetopt::Long::::Configure Getopt::Long::Configure
1112µs2µsmain::::__ANON__ main::__ANON__ (xsub)
111700ns700nsmain::::CORE:subst main::CORE:subst (opcode)
0000s0sGetopt::Long::CallBack::::nameGetopt::Long::CallBack::name
0000s0sGetopt::Long::CallBack::::newGetopt::Long::CallBack::new
0000s0sGetopt::Long::::GetOptions Getopt::Long::GetOptions
0000s0sGetopt::Long::::GetOptionsFromString Getopt::Long::GetOptionsFromString
0000s0sGetopt::Long::::HelpMessage Getopt::Long::HelpMessage
0000s0sGetopt::Long::::OptCtl Getopt::Long::OptCtl
0000s0sGetopt::Long::Parser::::configure Getopt::Long::Parser::configure
0000s0sGetopt::Long::Parser::::getoptions Getopt::Long::Parser::getoptions
0000s0sGetopt::Long::Parser::::getoptionsfromarray Getopt::Long::Parser::getoptionsfromarray
0000s0sGetopt::Long::Parser::::new Getopt::Long::Parser::new
0000s0sGetopt::Long::::VERSION Getopt::Long::VERSION
0000s0sGetopt::Long::::ValidValue Getopt::Long::ValidValue
0000s0sGetopt::Long::::VersionMessage Getopt::Long::VersionMessage
0000s0sGetopt::Long::::config Getopt::Long::config
0000s0sGetopt::Long::::setup_pa_args Getopt::Long::setup_pa_args
0000s0smain::::RUNTIME main::RUNTIME
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#! perl
2
3# Getopt::Long.pm -- Universal options parsing
4# Author : Johan Vromans
5# Created On : Tue Sep 11 15:00:12 1990
6# Last Modified By: Johan Vromans
7# Last Modified On: Sat May 27 12:11:39 2017
8# Update Count : 1715
9# Status : Released
10
11################ Module Preamble ################
12
13252µs125µs
# spent 25µs within main::BEGIN@13 which was called: # once (25µs+0s) by main::BEGIN@8 at line 13
use 5.004;
# spent 25µs making 1 call to main::BEGIN@13
14
15223µs222µs
# spent 17µs (12+5) within main::BEGIN@15 which was called: # once (12µs+5µs) by main::BEGIN@8 at line 15
use strict;
# spent 17µs making 1 call to main::BEGIN@15 # spent 5µs making 1 call to strict::import
16237µs278µs
# spent 43µs (9+34) within main::BEGIN@16 which was called: # once (9µs+34µs) by main::BEGIN@8 at line 16
use warnings;
# spent 43µs making 1 call to main::BEGIN@16 # spent 34µs making 1 call to warnings::import
17
18package Getopt::Long;
19
20234µs268µs
# spent 39µs (9+30) within Getopt::Long::BEGIN@20 which was called: # once (9µs+30µs) by main::BEGIN@8 at line 20
use vars qw($VERSION);
# spent 39µs making 1 call to Getopt::Long::BEGIN@20 # spent 30µs making 1 call to vars::import
211800ns$VERSION = 2.50;
22# For testing versions only.
23226µs232µs
# spent 19µs (6+13) within Getopt::Long::BEGIN@23 which was called: # once (6µs+13µs) by main::BEGIN@8 at line 23
use vars qw($VERSION_STRING);
# spent 19µs making 1 call to Getopt::Long::BEGIN@23 # spent 13µs making 1 call to vars::import
241700ns$VERSION_STRING = "2.50";
25
26228µs235µs
# spent 22µs (8+13) within Getopt::Long::BEGIN@26 which was called: # once (8µs+13µs) by main::BEGIN@8 at line 26
use Exporter;
# spent 22µs making 1 call to Getopt::Long::BEGIN@26 # spent 13µs making 1 call to Exporter::import
272125µs262µs
# spent 33µs (5+28) within Getopt::Long::BEGIN@27 which was called: # once (5µs+28µs) by main::BEGIN@8 at line 27
use vars qw(@ISA @EXPORT @EXPORT_OK);
# spent 33µs making 1 call to Getopt::Long::BEGIN@27 # spent 28µs making 1 call to vars::import
28111µs@ISA = qw(Exporter);
29
30# Exported subroutines.
31sub GetOptions(@); # always
32sub GetOptionsFromArray(@); # on demand
33sub GetOptionsFromString(@); # on demand
34sub Configure(@); # on demand
35sub HelpMessage(@); # on demand
36sub VersionMessage(@); # in demand
37
38
# spent 5µs within Getopt::Long::BEGIN@38 which was called: # once (5µs+0s) by main::BEGIN@8 at line 43
BEGIN {
39 # Init immediately so their contents can be used in the 'use vars' below.
401900ns @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
4115µs @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
42 &GetOptionsFromArray &GetOptionsFromString);
43124µs15µs}
# spent 5µs making 1 call to Getopt::Long::BEGIN@38
44
45# User visible variables.
46225µs2142µs
# spent 74µs (5+68) within Getopt::Long::BEGIN@46 which was called: # once (5µs+68µs) by main::BEGIN@8 at line 46
use vars @EXPORT, @EXPORT_OK;
# spent 74µs making 1 call to Getopt::Long::BEGIN@46 # spent 68µs making 1 call to vars::import
47226µs280µs
# spent 42µs (5+37) within Getopt::Long::BEGIN@47 which was called: # once (5µs+37µs) by main::BEGIN@8 at line 47
use vars qw($error $debug $major_version $minor_version);
# spent 42µs making 1 call to Getopt::Long::BEGIN@47 # spent 37µs making 1 call to vars::import
48# Deprecated visible variables.
4913µs148µs
# spent 53µs (5+48) within Getopt::Long::BEGIN@49 which was called: # once (5µs+48µs) by main::BEGIN@8 at line 50
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
# spent 48µs making 1 call to vars::import
50122µs153µs $passthrough);
# spent 53µs making 1 call to Getopt::Long::BEGIN@49
51# Official invisible variables.
522714µs287µs
# spent 46µs (5+41) within Getopt::Long::BEGIN@52 which was called: # once (5µs+41µs) by main::BEGIN@8 at line 52
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# spent 46µs making 1 call to Getopt::Long::BEGIN@52 # spent 41µs making 1 call to vars::import
53
54# Really invisible variables.
551100nsmy $bundling_values;
56
57# Public subroutines.
58sub config(@); # deprecated name
59
60# Private subroutines.
61sub ConfigDefaults();
62sub ParseOptionSpec($$);
63sub OptCtl($);
64sub FindOption($$$$$);
65sub ValidValue ($$$$$);
66
67################ Local Variables ################
68
69# $requested_version holds the version that was mentioned in the 'use'
70# or 'require', if any. It can be used to enable or disable specific
71# features.
721100nsmy $requested_version = 0;
73
74################ Resident subroutines ################
75
76
# spent 8µs within Getopt::Long::ConfigDefaults which was called: # once (8µs+0s) by main::BEGIN@8 at line 131
sub ConfigDefaults() {
77 # Handle POSIX compliancy.
7811µs if ( defined $ENV{"POSIXLY_CORRECT"} ) {
79 $genprefix = "(--|-)";
80 $autoabbrev = 0; # no automatic abbrev of options
81 $bundling = 0; # no bundling of single letter switches
82 $getopt_compat = 0; # disallow '+' to start options
83 $order = $REQUIRE_ORDER;
84 }
85 else {
861900ns $genprefix = "(--|-|\\+)";
871400ns $autoabbrev = 1; # automatic abbrev of options
881600ns $bundling = 0; # bundling off by default
891100ns $getopt_compat = 1; # allow '+' to start options
901500ns $order = $PERMUTE;
91 }
92 # Other configurable settings.
9311µs $debug = 0; # for debugging
941300ns $error = 0; # error tally
951300ns $ignorecase = 1; # ignore case when matching options
961200ns $passthrough = 0; # leave unrecognized options alone
971200ns $gnu_compat = 0; # require --opt=val if value is optional
981900ns $longprefix = "(--)"; # what does a long prefix look like
9913µs $bundling_values = 0; # no bundling of values
100}
101
102# Override import.
103
# spent 188µs (13+175) within Getopt::Long::import which was called: # once (13µs+175µs) by main::BEGIN@8 at line 8 of /root/tor-browser-build/rbm/rbm
sub import {
1041500ns my $pkg = shift; # package
1051300ns my @syms = (); # symbols to import
1061100ns my @config = (); # configuration
1071800ns my $dest = \@syms; # symbols first
1081700ns for ( @_ ) {
109 if ( $_ eq ':config' ) {
110 $dest = \@config; # config next
111 next;
112 }
113 push(@$dest, $_); # push
114 }
115 # Hide one level and call super.
1161900ns local $Exporter::ExportLevel = 1;
1171500ns push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
1181500ns $requested_version = 0;
11916µs1175µs $pkg->SUPER::import(@syms);
# spent 175µs making 1 call to Exporter::import
120 # And configure.
12114µs Configure(@config) if @config;
122}
123
124################ Initialization ################
125
126# Values for $order. See GNU getopt.c for details.
1271800ns($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
128# Version major/minor numbers.
129132µs124µs($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
# spent 24µs making 1 call to Getopt::Long::CORE:match
130
13112µs18µsConfigDefaults();
# spent 8µs making 1 call to Getopt::Long::ConfigDefaults
132
133################ OO Interface ################
134
135package Getopt::Long::Parser;
136
137# Store a copy of the default configuration. Since ConfigDefaults has
138# just been called, what we get from Configure is the default.
1391800ns14µsmy $default_config = do {
# spent 4µs making 1 call to Getopt::Long::Configure
140 Getopt::Long::Configure ()
141};
142
143sub new {
144 my $that = shift;
145 my $class = ref($that) || $that;
146 my %atts = @_;
147
148 # Register the callers package.
149 my $self = { caller_pkg => (caller)[0] };
150
151 bless ($self, $class);
152
153 # Process config attributes.
154 if ( defined $atts{config} ) {
155 my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
156 $self->{settings} = Getopt::Long::Configure ($save);
157 delete ($atts{config});
158 }
159 # Else use default config.
160 else {
161 $self->{settings} = $default_config;
162 }
163
164 if ( %atts ) { # Oops
165 die(__PACKAGE__.": unhandled attributes: ".
166 join(" ", sort(keys(%atts)))."\n");
167 }
168
169 $self;
170}
171
172sub configure {
173 my ($self) = shift;
174
175 # Restore settings, merge new settings in.
176 my $save = Getopt::Long::Configure ($self->{settings}, @_);
177
178 # Restore orig config and save the new config.
179 $self->{settings} = Getopt::Long::Configure ($save);
180}
181
182sub getoptions {
183 my ($self) = shift;
184
185 return $self->getoptionsfromarray(\@ARGV, @_);
186}
187
188sub getoptionsfromarray {
189 my ($self) = shift;
190
191 # Restore config settings.
192 my $save = Getopt::Long::Configure ($self->{settings});
193
194 # Call main routine.
195 my $ret = 0;
196 $Getopt::Long::caller = $self->{caller_pkg};
197
198 eval {
199 # Locally set exception handler to default, otherwise it will
200 # be called implicitly here, and again explicitly when we try
201 # to deliver the messages.
202 local ($SIG{__DIE__}) = 'DEFAULT';
203 $ret = Getopt::Long::GetOptionsFromArray (@_);
204 };
205
206 # Restore saved settings.
207 Getopt::Long::Configure ($save);
208
209 # Handle errors and return value.
210 die ($@) if $@;
211 return $ret;
212}
213
214package Getopt::Long;
215
216################ Back to Normal ################
217
218# Indices in option control info.
219# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
220238µs2142µs
# spent 77µs (12+65) within Getopt::Long::BEGIN@220 which was called: # once (12µs+65µs) by main::BEGIN@8 at line 220
use constant CTL_TYPE => 0;
# spent 77µs making 1 call to Getopt::Long::BEGIN@220 # spent 65µs making 1 call to constant::import
221#use constant CTL_TYPE_FLAG => '';
222#use constant CTL_TYPE_NEG => '!';
223#use constant CTL_TYPE_INCR => '+';
224#use constant CTL_TYPE_INT => 'i';
225#use constant CTL_TYPE_INTINC => 'I';
226#use constant CTL_TYPE_XINT => 'o';
227#use constant CTL_TYPE_FLOAT => 'f';
228#use constant CTL_TYPE_STRING => 's';
229
230222µs252µs
# spent 29µs (5+24) within Getopt::Long::BEGIN@230 which was called: # once (5µs+24µs) by main::BEGIN@8 at line 230
use constant CTL_CNAME => 1;
# spent 29µs making 1 call to Getopt::Long::BEGIN@230 # spent 24µs making 1 call to constant::import
231
232222µs268µs
# spent 46µs (24+22) within Getopt::Long::BEGIN@232 which was called: # once (24µs+22µs) by main::BEGIN@8 at line 232
use constant CTL_DEFAULT => 2;
# spent 46µs making 1 call to Getopt::Long::BEGIN@232 # spent 22µs making 1 call to constant::import
233
234224µs259µs
# spent 33µs (6+27) within Getopt::Long::BEGIN@234 which was called: # once (6µs+27µs) by main::BEGIN@8 at line 234
use constant CTL_DEST => 3;
# spent 33µs making 1 call to Getopt::Long::BEGIN@234 # spent 27µs making 1 call to constant::import
235220µs253µs
# spent 29µs (5+24) within Getopt::Long::BEGIN@235 which was called: # once (5µs+24µs) by main::BEGIN@8 at line 235
use constant CTL_DEST_SCALAR => 0;
# spent 29µs making 1 call to Getopt::Long::BEGIN@235 # spent 24µs making 1 call to constant::import
236221µs247µs
# spent 26µs (4+22) within Getopt::Long::BEGIN@236 which was called: # once (4µs+22µs) by main::BEGIN@8 at line 236
use constant CTL_DEST_ARRAY => 1;
# spent 26µs making 1 call to Getopt::Long::BEGIN@236 # spent 22µs making 1 call to constant::import
237220µs245µs
# spent 25µs (6+20) within Getopt::Long::BEGIN@237 which was called: # once (6µs+20µs) by main::BEGIN@8 at line 237
use constant CTL_DEST_HASH => 2;
# spent 25µs making 1 call to Getopt::Long::BEGIN@237 # spent 20µs making 1 call to constant::import
238219µs247µs
# spent 26µs (5+21) within Getopt::Long::BEGIN@238 which was called: # once (5µs+21µs) by main::BEGIN@8 at line 238
use constant CTL_DEST_CODE => 3;
# spent 26µs making 1 call to Getopt::Long::BEGIN@238 # spent 21µs making 1 call to constant::import
239
240223µs247µs
# spent 26µs (5+21) within Getopt::Long::BEGIN@240 which was called: # once (5µs+21µs) by main::BEGIN@8 at line 240
use constant CTL_AMIN => 4;
# spent 26µs making 1 call to Getopt::Long::BEGIN@240 # spent 21µs making 1 call to constant::import
241227µs246µs
# spent 25µs (4+20) within Getopt::Long::BEGIN@241 which was called: # once (4µs+20µs) by main::BEGIN@8 at line 241
use constant CTL_AMAX => 5;
# spent 25µs making 1 call to Getopt::Long::BEGIN@241 # spent 20µs making 1 call to constant::import
242
243# FFU.
244#use constant CTL_RANGE => ;
245#use constant CTL_REPEAT => ;
246
247# Rather liberal patterns to match numbers.
248238µs245µs
# spent 25µs (4+21) within Getopt::Long::BEGIN@248 which was called: # once (4µs+21µs) by main::BEGIN@8 at line 248
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
# spent 25µs making 1 call to Getopt::Long::BEGIN@248 # spent 20µs making 1 call to constant::import
24913µs126µs
# spent 31µs (5+26) within Getopt::Long::BEGIN@249 which was called: # once (5µs+26µs) by main::BEGIN@8 at line 258
use constant PAT_XINT =>
# spent 26µs making 1 call to constant::import
250 "(?:".
251 "[-+]?_*[1-9][0-9_]*".
252 "|".
253 "0x_*[0-9a-f][0-9a-f_]*".
254 "|".
255 "0b_*[01][01_]*".
256 "|".
257 "0[0-7_]*".
258134µs131µs ")";
# spent 31µs making 1 call to Getopt::Long::BEGIN@249
25914µs151µs
# spent 58µs (7+51) within Getopt::Long::BEGIN@259 which was called: # once (7µs+51µs) by main::BEGIN@8 at line 264
use constant PAT_FLOAT =>
# spent 51µs making 1 call to constant::import
260 "[-+]?". # optional sign
261 "(?=[0-9.])". # must start with digit or dec.point
262 "[0-9_]*". # digits before the dec.point
263 "(\.[0-9_]+)?". # optional fraction
26416.93ms158µs "([eE][-+]?[0-9_]+)?"; # optional exponent
# spent 58µs making 1 call to Getopt::Long::BEGIN@259
265
266sub GetOptions(@) {
267 # Shift in default array.
268 unshift(@_, \@ARGV);
269 # Try to keep caller() and Carp consistent.
270 goto &GetOptionsFromArray;
271}
272
273sub GetOptionsFromString(@) {
274 my ($string) = shift;
275 require Text::ParseWords;
276 my $args = [ Text::ParseWords::shellwords($string) ];
277 $caller ||= (caller)[0]; # current context
278 my $ret = GetOptionsFromArray($args, @_);
279 return ( $ret, $args ) if wantarray;
280 if ( @$args ) {
281 $ret = 0;
282 warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
283 }
284 $ret;
285}
286
287
# spent 1.00ms (235µs+769µs) within Getopt::Long::GetOptionsFromArray which was called: # once (235µs+769µs) by main::set_options at line 100 of /root/tor-browser-build/rbm/rbm
sub GetOptionsFromArray(@) {
288
28913µs my ($argv, @optionlist) = @_; # local copy of the option descriptions
2901800ns my $argend = '--'; # option list terminator
2911800ns my %opctl = (); # table of option specs
29212µs my $pkg = $caller || (caller)[0]; # current context
293 # Needed if linkage is omitted.
2941200ns my @ret = (); # accum for non-options
2951300ns my %linkage; # linkage
296 my $userlinkage; # user supplied HASH
297 my $opt; # current option
29811µs my $prefix = $genprefix; # current prefix
299
30011µs $error = '';
301
3021400ns if ( $debug ) {
303 # Avoid some warnings if debugging.
304 local ($^W) = 0;
305 print STDERR
306 ("Getopt::Long $Getopt::Long::VERSION ",
307 "called from package \"$pkg\".",
308 "\n ",
309 "argv: ",
310 defined($argv)
311 ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv
312 : "<undef>",
313 "\n ",
314 "autoabbrev=$autoabbrev,".
315 "bundling=$bundling,",
316 "bundling_values=$bundling_values,",
317 "getopt_compat=$getopt_compat,",
318 "gnu_compat=$gnu_compat,",
319 "order=$order,",
320 "\n ",
321 "ignorecase=$ignorecase,",
322 "requested_version=$requested_version,",
323 "passthrough=$passthrough,",
324 "genprefix=\"$genprefix\",",
325 "longprefix=\"$longprefix\".",
326 "\n");
327 }
328
329 # Check for ref HASH as first argument.
330 # First argument may be an object. It's OK to use this as long
331 # as it is really a hash underneath.
3321600ns $userlinkage = undef;
33318µs12µs if ( @optionlist && ref($optionlist[0]) and
# spent 2µs making 1 call to UNIVERSAL::isa
334 UNIVERSAL::isa($optionlist[0],'HASH') ) {
3351500ns $userlinkage = shift (@optionlist);
3361200ns print STDERR ("=> user linkage: $userlinkage\n") if $debug;
337 }
338
339 # See if the first element of the optionlist contains option
340 # starter characters.
341 # Be careful not to interpret '<>' as option starters.
34217µs12µs if ( @optionlist && $optionlist[0] =~ /^\W+$/
# spent 2µs making 1 call to Getopt::Long::CORE:match
343 && !($optionlist[0] eq '<>'
344 && @optionlist > 0
345 && ref($optionlist[1])) ) {
346 $prefix = shift (@optionlist);
347 # Turn into regexp. Needs to be parenthesized!
348 $prefix =~ s/(\W)/\\$1/g;
349 $prefix = "([" . $prefix . "])";
350 print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
351 }
352
353 # Verify correctness of optionlist.
3541800ns %opctl = ();
35514µs while ( @optionlist ) {
356278µs my $opt = shift (@optionlist);
357
358273µs unless ( defined($opt) ) {
359 $error .= "Undefined argument in option spec\n";
360 next;
361 }
362
363 # Strip leading prefix so people can specify "--foo=i" if they like.
36427118µs5461µs $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
# spent 45µs making 27 calls to Getopt::Long::CORE:regcomp, avg 2µs/call # spent 17µs making 27 calls to Getopt::Long::CORE:match, avg 615ns/call
365
366275µs if ( $opt eq '<>' ) {
367 if ( (defined $userlinkage)
368 && !(@optionlist > 0 && ref($optionlist[0]))
369 && (exists $userlinkage->{$opt})
370 && ref($userlinkage->{$opt}) ) {
371 unshift (@optionlist, $userlinkage->{$opt});
372 }
373 unless ( @optionlist > 0
374 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
375 $error .= "Option spec <> requires a reference to a subroutine\n";
376 # Kill the linkage (to avoid another error).
377 shift (@optionlist)
378 if @optionlist && ref($optionlist[0]);
379 next;
380 }
381 $linkage{'<>'} = shift (@optionlist);
382 next;
383 }
384
385 # Parse option spec.
3862730µs27436µs my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
# spent 436µs making 27 calls to Getopt::Long::ParseOptionSpec, avg 16µs/call
387273µs unless ( defined $name ) {
388 # Failed. $orig contains the error message. Sorry for the abuse.
389 $error .= $orig;
390 # Kill the linkage (to avoid another error).
391 shift (@optionlist)
392 if @optionlist && ref($optionlist[0]);
393 next;
394 }
395
396 # If no linkage is supplied in the @optionlist, copy it from
397 # the userlinkage if available.
398274µs if ( defined $userlinkage ) {
399277µs unless ( @optionlist > 0 && ref($optionlist[0]) ) {
400275µs if ( exists $userlinkage->{$orig} &&
401 ref($userlinkage->{$orig}) ) {
402 print STDERR ("=> found userlinkage for \"$orig\": ",
403 "$userlinkage->{$orig}\n")
404 if $debug;
405 unshift (@optionlist, $userlinkage->{$orig});
406 }
407 else {
408 # Do nothing. Being undefined will be handled later.
4092715µs next;
410 }
411 }
412 }
413
414 # Copy the linkage. If omitted, link to global variable.
415 if ( @optionlist > 0 && ref($optionlist[0]) ) {
416 print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
417 if $debug;
418 my $rl = ref($linkage{$orig} = shift (@optionlist));
419
420 if ( $rl eq "ARRAY" ) {
421 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
422 }
423 elsif ( $rl eq "HASH" ) {
424 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
425 }
426 elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
427# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
428# my $t = $linkage{$orig};
429# $$t = $linkage{$orig} = [];
430# }
431# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
432# }
433# else {
434 # Ok.
435# }
436 }
437 elsif ( $rl eq "CODE" ) {
438 # Ok.
439 }
440 else {
441 $error .= "Invalid option linkage for \"$opt\"\n";
442 }
443 }
444 else {
445 # Link to global $opt_XXX variable.
446 # Make sure a valid perl identifier results.
447 my $ov = $orig;
448 $ov =~ s/\W/_/g;
449 if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
450 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
451 if $debug;
452 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
453 }
454 elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
455 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
456 if $debug;
457 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
458 }
459 else {
460 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
461 if $debug;
462 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
463 }
464 }
465
466 if ( $opctl{$name}[CTL_TYPE] eq 'I'
467 && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
468 || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
469 ) {
470 $error .= "Invalid option linkage for \"$opt\"\n";
471 }
472
473 }
474
47514µs1700ns $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
# spent 700ns making 1 call to UNIVERSAL::isa
476 unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );
477
478 # Bail out if errors found.
4791400ns die ($error) if $error;
4801400ns $error = 0;
481
482 # Supply --version and --help support, if needed and allowed.
48312µs if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
484 if ( !defined($opctl{version}) ) {
485 $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
486 $linkage{version} = \&VersionMessage;
487 }
488 $auto_version = 1;
489 }
49012µs if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
491 if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
492 $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
493 $linkage{help} = \&HelpMessage;
494 }
495 $auto_help = 1;
496 }
497
498 # Show the options tables if debugging.
4991400ns if ( $debug ) {
500 my ($arrow, $k, $v);
501 $arrow = "=> ";
502 while ( ($k,$v) = each(%opctl) ) {
503 print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
504 $arrow = " ";
505 }
506 }
507
508 # Process argument list
50911µs my $goon = 1;
51011µs while ( $goon && @$argv > 0 ) {
511
512 # Get next argument.
51331µs $opt = shift (@$argv);
5143700ns print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
515
516 # Double dash is option list terminator.
51731µs if ( defined($opt) && $opt eq $argend ) {
518 push (@ret, $argend) if $passthrough;
519 last;
520 }
521
522 # Look it up.
5233900ns my $tryopt = $opt;
5243800ns my $found; # success status
525 my $key; # key (if hash type)
526 my $arg; # option argument
527 my $ctl; # the opctl entry
528
52937µs3266µs ($found, $opt, $ctl, $arg, $key) =
# spent 266µs making 3 calls to Getopt::Long::FindOption, avg 89µs/call
530 FindOption ($argv, $prefix, $argend, $opt, \%opctl);
531
53232µs if ( $found ) {
533
534 # FindOption undefines $opt in case of errors.
5352400ns next unless defined $opt;
536
5372500ns my $argcnt = 0;
5382500ns while ( defined $arg ) {
539
540 # Get the canonical name.
5412400ns print STDERR ("=> cname for \"$opt\" is ") if $debug;
5422900ns $opt = $ctl->[CTL_CNAME];
5432600ns print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
544
54522µs if ( defined $linkage{$opt} ) {
546 print STDERR ("=> ref(\$L{$opt}) -> ",
547 ref($linkage{$opt}), "\n") if $debug;
548
549 if ( ref($linkage{$opt}) eq 'SCALAR'
550 || ref($linkage{$opt}) eq 'REF' ) {
551 if ( $ctl->[CTL_TYPE] eq '+' ) {
552 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
553 if $debug;
554 if ( defined ${$linkage{$opt}} ) {
555 ${$linkage{$opt}} += $arg;
556 }
557 else {
558 ${$linkage{$opt}} = $arg;
559 }
560 }
561 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
562 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
563 " to ARRAY\n")
564 if $debug;
565 my $t = $linkage{$opt};
566 $$t = $linkage{$opt} = [];
567 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
568 if $debug;
569 push (@{$linkage{$opt}}, $arg);
570 }
571 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
572 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
573 " to HASH\n")
574 if $debug;
575 my $t = $linkage{$opt};
576 $$t = $linkage{$opt} = {};
577 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
578 if $debug;
579 $linkage{$opt}->{$key} = $arg;
580 }
581 else {
582 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
583 if $debug;
584 ${$linkage{$opt}} = $arg;
585 }
586 }
587 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
588 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
589 if $debug;
590 push (@{$linkage{$opt}}, $arg);
591 }
592 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
593 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
594 if $debug;
595 $linkage{$opt}->{$key} = $arg;
596 }
597 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
598 print STDERR ("=> &L{$opt}(\"$opt\"",
599 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
600 ", \"$arg\")\n")
601 if $debug;
602 my $eval_error = do {
603 local $@;
604 local $SIG{__DIE__} = 'DEFAULT';
605 eval {
606 &{$linkage{$opt}}
607 (Getopt::Long::CallBack->new
608 (name => $opt,
609 ctl => $ctl,
610 opctl => \%opctl,
611 linkage => \%linkage,
612 prefix => $prefix,
613 ),
614 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
615 $arg);
616 };
617 $@;
618 };
619 print STDERR ("=> die($eval_error)\n")
620 if $debug && $eval_error ne '';
621 if ( $eval_error =~ /^!/ ) {
622 if ( $eval_error =~ /^!FINISH\b/ ) {
623 $goon = 0;
624 }
625 }
626 elsif ( $eval_error ne '' ) {
627 warn ($eval_error);
628 $error++;
629 }
630 }
631 else {
632 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
633 "\" in linkage\n");
634 die("Getopt::Long -- internal error!\n");
635 }
636 }
637 # No entry in linkage means entry in userlinkage.
638 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
63921µs if ( defined $userlinkage->{$opt} ) {
6401200ns print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
641 if $debug;
64211µs push (@{$userlinkage->{$opt}}, $arg);
643 }
644 else {
6451200ns print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
646 if $debug;
6471900ns $userlinkage->{$opt} = [$arg];
648 }
649 }
650 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
651 if ( defined $userlinkage->{$opt} ) {
652 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
653 if $debug;
654 $userlinkage->{$opt}->{$key} = $arg;
655 }
656 else {
657 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
658 if $debug;
659 $userlinkage->{$opt} = {$key => $arg};
660 }
661 }
662 else {
663 if ( $ctl->[CTL_TYPE] eq '+' ) {
664 print STDERR ("=> \$L{$opt} += \"$arg\"\n")
665 if $debug;
666 if ( defined $userlinkage->{$opt} ) {
667 $userlinkage->{$opt} += $arg;
668 }
669 else {
670 $userlinkage->{$opt} = $arg;
671 }
672 }
673 else {
674 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
675 $userlinkage->{$opt} = $arg;
676 }
677 }
678
6792500ns $argcnt++;
68023µs last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
681 undef($arg);
682
683 # Need more args?
684 if ( $argcnt < $ctl->[CTL_AMIN] ) {
685 if ( @$argv ) {
686 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
687 $arg = shift(@$argv);
688 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
689 $arg =~ tr/_//d;
690 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
691 ? oct($arg)
692 : 0+$arg
693 }
694 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
695 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
696 next;
697 }
698 warn("Value \"$$argv[0]\" invalid for option $opt\n");
699 $error++;
700 }
701 else {
702 warn("Insufficient arguments for option $opt\n");
703 $error++;
704 }
705 }
706
707 # Any more args?
708 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
709 $arg = shift(@$argv);
710 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
711 $arg =~ tr/_//d;
712 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
713 ? oct($arg)
714 : 0+$arg
715 }
716 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
717 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
718 next;
719 }
720 }
721 }
722
723 # Not an option. Save it if we $PERMUTE and don't have a <>.
724 elsif ( $order == $PERMUTE ) {
725 # Try non-options call-back.
7261200ns my $cb;
7271700ns if ( defined ($cb = $linkage{'<>'}) ) {
728 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
729 if $debug;
730 my $eval_error = do {
731 local $@;
732 local $SIG{__DIE__} = 'DEFAULT';
733 eval {
734 # The arg to <> cannot be the CallBack object
735 # since it may be passed to other modules that
736 # get confused (e.g., Archive::Tar). Well,
737 # it's not relevant for this callback anyway.
738 &$cb($tryopt);
739 };
740 $@;
741 };
742 print STDERR ("=> die($eval_error)\n")
743 if $debug && $eval_error ne '';
744 if ( $eval_error =~ /^!/ ) {
745 if ( $eval_error =~ /^!FINISH\b/ ) {
746 $goon = 0;
747 }
748 }
749 elsif ( $eval_error ne '' ) {
750 warn ($eval_error);
751 $error++;
752 }
753 }
754 else {
7551200ns print STDERR ("=> saving \"$tryopt\" ",
756 "(not an option, may permute)\n") if $debug;
7571500ns push (@ret, $tryopt);
758 }
7591600ns next;
760 }
761
762 # ...otherwise, terminate.
763 else {
764 # Push this one back and exit.
765 unshift (@$argv, $tryopt);
766 return ($error == 0);
767 }
768
769 }
770
771 # Finish.
77211µs if ( @ret && $order == $PERMUTE ) {
773 # Push back accumulated arguments
77410s print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
775 if $debug;
7761500ns unshift (@$argv, @ret);
777 }
778
779113µs return ($error == 0);
780}
781
782# A readable representation of what's in an optbl.
783sub OptCtl ($) {
784 my ($v) = @_;
785 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
786 "[".
787 join(",",
788 "\"$v[CTL_TYPE]\"",
789 "\"$v[CTL_CNAME]\"",
790 "\"$v[CTL_DEFAULT]\"",
791 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
792 $v[CTL_AMIN] || '',
793 $v[CTL_AMAX] || '',
794# $v[CTL_RANGE] || '',
795# $v[CTL_REPEAT] || '',
796 ). "]";
797}
798
799# Parse an option specification and fill the tables.
800
# spent 436µs (358+78) within Getopt::Long::ParseOptionSpec which was called 27 times, avg 16µs/call: # 27 times (358µs+78µs) by Getopt::Long::GetOptionsFromArray at line 386, avg 16µs/call
sub ParseOptionSpec ($$) {
801276µs my ($opt, $opctl) = @_;
802
803 # Match option spec.
8042769µs2743µs if ( $opt !~ m;^
# spent 43µs making 27 calls to Getopt::Long::CORE:match, avg 2µs/call
805 (
806 # Option name
807 (?: \w+[-\w]* )
808 # Alias names, or "?"
809 (?: \| (?: \? | \w[-\w]* ) )*
810 # Aliases
811 (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
812 )?
813 (
814 # Either modifiers ...
815 [!+]
816 |
817 # ... or a value/dest/repeat specification
818 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
819 |
820 # ... or an optional-with-default spec
821 : (?: -?\d+ | \+ ) [@%]?
822 )?
823 $;x ) {
824 return (undef, "Error in option spec: \"$opt\"\n");
825 }
826
8272720µs my ($names, $spec) = ($1, $2);
828273µs $spec = '' unless defined $spec;
829
830 # $orig keeps track of the primary name the user specified.
831 # This name will be used for the internal or external linkage.
832 # In other words, if the user specifies "FoO|BaR", it will
833 # match any case combinations of 'foo' and 'bar', but if a global
834 # variable needs to be set, it will be $opt_FoO in the exact case
835 # as specified.
836273µs my $orig;
837
838 my @names;
839277µs if ( defined $names ) {
8402716µs @names = split (/\|/, $names);
841276µs $orig = $names[0];
842 }
843 else {
844 @names = ('');
845 $orig = '';
846 }
847
848 # Construct the opctl entries.
849272µs my $entry;
8502743µs245µs if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# spent 5µs making 24 calls to Getopt::Long::CORE:match, avg 192ns/call
851 # Fields are hard-wired here.
852 $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
853 }
854 elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
855 my $def = $1;
856 my $dest = $2;
857 my $type = $def eq '+' ? 'I' : 'i';
858 $dest ||= '$';
859 $dest = $dest eq '@' ? CTL_DEST_ARRAY
860 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
861 # Fields are hard-wired here.
862 $entry = [$type,$orig,$def eq '+' ? undef : $def,
863 $dest,0,1];
864 }
865 else {
8662466µs2430µs my ($mand, $type, $dest) =
# spent 30µs making 24 calls to Getopt::Long::CORE:match, avg 1µs/call
867 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
868243µs return (undef, "Cannot repeat while bundling: \"$opt\"\n")
869 if $bundling && defined($4);
8702414µs my ($mi, $cm, $ma) = ($5, $6, $7);
871244µs return (undef, "{0} is useless in option spec: \"$opt\"\n")
872 if defined($mi) && !$mi && !defined($ma) && !defined($cm);
873
874244µs $type = 'i' if $type eq 'n';
875245µs $dest ||= '$';
876248µs $dest = $dest eq '@' ? CTL_DEST_ARRAY
877 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
878 # Default minargs to 1/0 depending on mand status.
879246µs $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
880 # Adjust mand status according to minargs.
881245µs $mand = $mi ? '=' : ':';
882 # Adjust maxargs.
883246µs $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
884244µs return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
885 if defined($ma) && !$ma;
886244µs return (undef, "Max less than min in option spec: \"$opt\"\n")
887 if defined($ma) && $ma < $mi;
888
889 # Fields are hard-wired here.
8902423µs $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
891 }
892
893 # Process all names. First is canonical, the rest are aliases.
894275µs my $dups = '';
895279µs foreach ( @names ) {
896
8972713µs $_ = lc ($_)
898 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
899
900276µs if ( exists $opctl->{$_} ) {
901 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
902 }
903
9042713µs if ( $spec eq '!' ) {
90533µs $opctl->{"no$_"} = $entry;
90634µs $opctl->{"no-$_"} = $entry;
90733µs $opctl->{$_} = [@$entry];
90831µs $opctl->{$_}->[CTL_TYPE] = '';
909 }
910 else {
9112414µs $opctl->{$_} = $entry;
912 }
913 }
914
915273µs if ( $dups && $^W ) {
916 foreach ( split(/\n+/, $dups) ) {
917 warn($_."\n");
918 }
919 }
9202751µs ($names[0], $orig);
921}
922
923# Option lookup.
924
# spent 266µs (194+73) within Getopt::Long::FindOption which was called 3 times, avg 89µs/call: # 3 times (194µs+73µs) by Getopt::Long::GetOptionsFromArray at line 529, avg 89µs/call
sub FindOption ($$$$$) {
925
926 # returns (1, $opt, $ctl, $arg, $key) if okay,
927 # returns (1, undef) if option in error,
928 # returns (0) otherwise.
929
93032µs my ($argv, $prefix, $argend, $opt, $opctl) = @_;
931
9323900ns print STDERR ("=> find \"$opt\"\n") if $debug;
933
93431µs return (0) unless defined($opt);
935332µs620µs return (0) unless $opt =~ /^($prefix)(.*)$/s;
# spent 16µs making 3 calls to Getopt::Long::CORE:regcomp, avg 5µs/call # spent 4µs making 3 calls to Getopt::Long::CORE:match, avg 1µs/call
93621µs return (0) if $opt eq "-" && !defined $opctl->{''};
937
93822µs $opt = substr( $opt, length($1) ); # retain taintedness
93921µs my $starter = $1;
940
9412300ns print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
942
9432800ns my $optarg; # value supplied with --opt=value
944 my $rest; # remainder from unbundling
945
946 # If it is a long option, it may include the value.
947 # With getopt_compat, only if not bundling.
948217µs47µs if ( ($starter=~/^$longprefix$/
# spent 6µs making 2 calls to Getopt::Long::CORE:regcomp, avg 3µs/call # spent 2µs making 2 calls to Getopt::Long::CORE:match, avg 750ns/call
949 || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
950 && (my $oppos = index($opt, '=', 1)) > 0) {
951 my $optorg = $opt;
952 $opt = substr($optorg, 0, $oppos);
953 $optarg = substr($optorg, $oppos + 1); # retain tainedness
954 print STDERR ("=> option \"", $opt,
955 "\", optarg = \"$optarg\"\n") if $debug;
956 }
957
958 #### Look it up ###
959
9602900ns my $tryopt = $opt; # option to try
961
96223µs if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
963
964 # To try overrides, obey case ignore.
965 $tryopt = $ignorecase ? lc($opt) : $opt;
966
967 # If bundling == 2, long options can override bundles.
968 if ( $bundling == 2 && length($tryopt) > 1
969 && defined ($opctl->{$tryopt}) ) {
970 print STDERR ("=> $starter$tryopt overrides unbundling\n")
971 if $debug;
972 }
973
974 # If bundling_values, option may be followed by the value.
975 elsif ( $bundling_values ) {
976 $tryopt = $opt;
977 # Unbundle single letter option.
978 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
979 $tryopt = substr ($tryopt, 0, 1);
980 $tryopt = lc ($tryopt) if $ignorecase > 1;
981 print STDERR ("=> $starter$tryopt unbundled from ",
982 "$starter$tryopt$rest\n") if $debug;
983 # Whatever remains may not be considered an option.
984 $optarg = $rest eq '' ? undef : $rest;
985 $rest = undef;
986 }
987
988 # Split off a single letter and leave the rest for
989 # further processing.
990 else {
991 $tryopt = $opt;
992 # Unbundle single letter option.
993 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
994 $tryopt = substr ($tryopt, 0, 1);
995 $tryopt = lc ($tryopt) if $ignorecase > 1;
996 print STDERR ("=> $starter$tryopt unbundled from ",
997 "$starter$tryopt$rest\n") if $debug;
998 $rest = undef unless $rest ne '';
999 }
1000 }
1001
1002 # Try auto-abbreviation.
1003 elsif ( $autoabbrev && $opt ne "" ) {
1004 # Sort the possible long option names.
1005228µs213µs my @names = sort(keys (%$opctl));
# spent 13µs making 2 calls to Getopt::Long::CORE:sort, avg 6µs/call
1006 # Downcase if allowed.
100721µs $opt = lc ($opt) if $ignorecase;
10082700ns $tryopt = $opt;
1009 # Turn option name into pattern.
101021µs my $pat = quotemeta ($opt);
1011 # Look up in option names.
10122148µs13232µs my @hits = grep (/^$pat/, @names);
# spent 24µs making 66 calls to Getopt::Long::CORE:regcomp, avg 362ns/call # spent 8µs making 66 calls to Getopt::Long::CORE:match, avg 121ns/call
10132700ns print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1014 "out of ", scalar(@names), "\n") if $debug;
1015
1016 # Check for ambiguous results.
101721µs unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
1018 # See if all matches are for the same option.
1019 my %hit;
1020 foreach ( @hits ) {
1021 my $hit = $opctl->{$_}->[CTL_CNAME]
1022 if defined $opctl->{$_}->[CTL_CNAME];
1023 $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
1024 $hit{$hit} = 1;
1025 }
1026 # Remove auto-supplied options (version, help).
1027 if ( keys(%hit) == 2 ) {
1028 if ( $auto_version && exists($hit{version}) ) {
1029 delete $hit{version};
1030 }
1031 elsif ( $auto_help && exists($hit{help}) ) {
1032 delete $hit{help};
1033 }
1034 }
1035 # Now see if it really is ambiguous.
1036 unless ( keys(%hit) == 1 ) {
1037 return (0) if $passthrough;
1038 warn ("Option ", $opt, " is ambiguous (",
1039 join(", ", @hits), ")\n");
1040 $error++;
1041 return (1, undef);
1042 }
1043 @hits = keys(%hit);
1044 }
1045
1046 # Complete the option name, if appropriate.
104723µs if ( @hits == 1 && $hits[0] ne $opt ) {
1048 $tryopt = $hits[0];
1049 $tryopt = lc ($tryopt)
1050 if $ignorecase > (($bundling && length($tryopt) == 1) ? 1 : 0);
1051 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1052 if $debug;
1053 }
1054 }
1055
1056 # Map to all lowercase if ignoring case.
1057 elsif ( $ignorecase ) {
1058 $tryopt = lc ($opt);
1059 }
1060
1061 # Check validity by fetching the info.
106222µs my $ctl = $opctl->{$tryopt};
10632300ns unless ( defined $ctl ) {
1064 return (0) if $passthrough;
1065 # Pretend one char when bundling.
1066 if ( $bundling == 1 && length($starter) == 1 ) {
1067 $opt = substr($opt,0,1);
1068 unshift (@$argv, $starter.$rest) if defined $rest;
1069 }
1070 if ( $opt eq "" ) {
1071 warn ("Missing option after ", $starter, "\n");
1072 }
1073 else {
1074 warn ("Unknown option: ", $opt, "\n");
1075 }
1076 $error++;
1077 return (1, undef);
1078 }
1079 # Apparently valid.
10802800ns $opt = $tryopt;
10812700ns print STDERR ("=> found ", OptCtl($ctl),
1082 " for \"", $opt, "\"\n") if $debug;
1083
1084 #### Determine argument status ####
1085
1086 # If it is an option w/o argument, we're almost finished with it.
108721µs my $type = $ctl->[CTL_TYPE];
10882300ns my $arg;
1089
109021µs if ( $type eq '' || $type eq '!' || $type eq '+' ) {
1091 if ( defined $optarg ) {
1092 return (0) if $passthrough;
1093 warn ("Option ", $opt, " does not take an argument\n");
1094 $error++;
1095 undef $opt;
1096 undef $optarg if $bundling_values;
1097 }
1098 elsif ( $type eq '' || $type eq '+' ) {
1099 # Supply explicit value.
1100 $arg = 1;
1101 }
1102 else {
1103 $opt =~ s/^no-?//i; # strip NO prefix
1104 $arg = 0; # supply explicit value
1105 }
1106 unshift (@$argv, $starter.$rest) if defined $rest;
1107 return (1, $opt, $ctl, $arg);
1108 }
1109
1110 # Get mandatory status and type info.
11112800ns my $mand = $ctl->[CTL_AMIN];
1112
1113 # Check if there is an option argument available.
11142600ns if ( $gnu_compat ) {
1115 my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux
1116 if ( defined($optarg) ) {
1117 $optargtype = (length($optarg) == 0) ? 1 : 2;
1118 }
1119 elsif ( defined $rest || @$argv > 0 ) {
1120 # GNU getopt_long() does not accept the (optional)
1121 # argument to be passed to the option without = sign.
1122 # We do, since not doing so breaks existing scripts.
1123 $optargtype = 3;
1124 }
1125 if(($optargtype == 0) && !$mand) {
1126 if ( $type eq 'I' ) {
1127 # Fake incremental type.
1128 my @c = @$ctl;
1129 $c[CTL_TYPE] = '+';
1130 return (1, $opt, \@c, 1);
1131 }
1132 my $val
1133 = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT]
1134 : $type eq 's' ? ''
1135 : 0;
1136 return (1, $opt, $ctl, $val);
1137 }
1138 return (1, $opt, $ctl, $type eq 's' ? '' : 0)
1139 if $optargtype == 1; # --foo= -> return nothing
1140 }
1141
1142 # Check if there is an option argument available.
114322µs if ( defined $optarg
1144 ? ($optarg eq '')
1145 : !(defined $rest || @$argv > 0) ) {
1146 # Complain if this option needs an argument.
1147# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1148 if ( $mand ) {
1149 return (0) if $passthrough;
1150 warn ("Option ", $opt, " requires an argument\n");
1151 $error++;
1152 return (1, undef);
1153 }
1154 if ( $type eq 'I' ) {
1155 # Fake incremental type.
1156 my @c = @$ctl;
1157 $c[CTL_TYPE] = '+';
1158 return (1, $opt, \@c, 1);
1159 }
1160 return (1, $opt, $ctl,
1161 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1162 $type eq 's' ? '' : 0);
1163 }
1164
1165 # Get (possibly optional) argument.
116622µs $arg = (defined $rest ? $rest
1167 : (defined $optarg ? $optarg : shift (@$argv)));
1168
1169 # Get key if this is a "name=value" pair for a hash option.
11702500ns my $key;
11712800ns if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1172 ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1173 : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1174 ($mand ? undef : ($type eq 's' ? "" : 1)));
1175 if (! defined $arg) {
1176 warn ("Option $opt, key \"$key\", requires a value\n");
1177 $error++;
1178 # Push back.
1179 unshift (@$argv, $starter.$rest) if defined $rest;
1180 return (1, undef);
1181 }
1182 }
1183
1184 #### Check if the argument is valid for this option ####
1185
118622µs my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1187
118822µs if ( $type eq 's' ) { # string
1189 # A mandatory string takes anything.
119026µs return (1, $opt, $ctl, $arg, $key) if $mand;
1191
1192 # Same for optional string as a hash value
1193 return (1, $opt, $ctl, $arg, $key)
1194 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1195
1196 # An optional string takes almost anything.
1197 return (1, $opt, $ctl, $arg, $key)
1198 if defined $optarg || defined $rest;
1199 return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1200
1201 # Check for option or option list terminator.
1202 if ($arg eq $argend ||
1203 $arg =~ /^$prefix.+/) {
1204 # Push back.
1205 unshift (@$argv, $arg);
1206 # Supply empty value.
1207 $arg = '';
1208 }
1209 }
1210
1211 elsif ( $type eq 'i' # numeric/integer
1212 || $type eq 'I' # numeric/integer w/ incr default
1213 || $type eq 'o' ) { # dec/oct/hex/bin value
1214
1215 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1216
1217 if ( $bundling && defined $rest
1218 && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1219 ($key, $arg, $rest) = ($1, $2, $+);
1220 chop($key) if $key;
1221 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1222 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1223 }
1224 elsif ( $arg =~ /^$o_valid$/si ) {
1225 $arg =~ tr/_//d;
1226 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1227 }
1228 else {
1229 if ( defined $optarg || $mand ) {
1230 if ( $passthrough ) {
1231 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1232 unless defined $optarg;
1233 return (0);
1234 }
1235 warn ("Value \"", $arg, "\" invalid for option ",
1236 $opt, " (",
1237 $type eq 'o' ? "extended " : '',
1238 "number expected)\n");
1239 $error++;
1240 # Push back.
1241 unshift (@$argv, $starter.$rest) if defined $rest;
1242 return (1, undef);
1243 }
1244 else {
1245 # Push back.
1246 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1247 if ( $type eq 'I' ) {
1248 # Fake incremental type.
1249 my @c = @$ctl;
1250 $c[CTL_TYPE] = '+';
1251 return (1, $opt, \@c, 1);
1252 }
1253 # Supply default value.
1254 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1255 }
1256 }
1257 }
1258
1259 elsif ( $type eq 'f' ) { # real number, int is also ok
1260 my $o_valid = PAT_FLOAT;
1261 if ( $bundling && defined $rest &&
1262 $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1263 $arg =~ tr/_//d;
1264 ($key, $arg, $rest) = ($1, $2, $+);
1265 chop($key) if $key;
1266 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1267 }
1268 elsif ( $arg =~ /^$o_valid$/ ) {
1269 $arg =~ tr/_//d;
1270 }
1271 else {
1272 if ( defined $optarg || $mand ) {
1273 if ( $passthrough ) {
1274 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1275 unless defined $optarg;
1276 return (0);
1277 }
1278 warn ("Value \"", $arg, "\" invalid for option ",
1279 $opt, " (real number expected)\n");
1280 $error++;
1281 # Push back.
1282 unshift (@$argv, $starter.$rest) if defined $rest;
1283 return (1, undef);
1284 }
1285 else {
1286 # Push back.
1287 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1288 # Supply default value.
1289 $arg = 0.0;
1290 }
1291 }
1292 }
1293 else {
1294 die("Getopt::Long internal error (Can't happen)\n");
1295 }
1296 return (1, $opt, $ctl, $arg, $key);
1297}
1298
1299sub ValidValue ($$$$$) {
1300 my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1301
1302 if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1303 return 0 unless $arg =~ /[^=]+=(.*)/;
1304 $arg = $1;
1305 }
1306
1307 my $type = $ctl->[CTL_TYPE];
1308
1309 if ( $type eq 's' ) { # string
1310 # A mandatory string takes anything.
1311 return (1) if $mand;
1312
1313 return (1) if $arg eq "-";
1314
1315 # Check for option or option list terminator.
1316 return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1317 return 1;
1318 }
1319
1320 elsif ( $type eq 'i' # numeric/integer
1321 || $type eq 'I' # numeric/integer w/ incr default
1322 || $type eq 'o' ) { # dec/oct/hex/bin value
1323
1324 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1325 return $arg =~ /^$o_valid$/si;
1326 }
1327
1328 elsif ( $type eq 'f' ) { # real number, int is also ok
1329 my $o_valid = PAT_FLOAT;
1330 return $arg =~ /^$o_valid$/;
1331 }
1332 die("ValidValue: Cannot happen\n");
1333}
1334
1335# Getopt::Long Configuration.
1336
# spent 4µs within Getopt::Long::Configure which was called: # once (4µs+0s) by main::BEGIN@8 at line 139
sub Configure (@) {
13371300ns my (@options) = @_;
1338
133912µs my $prevconfig =
1340 [ $error, $debug, $major_version, $minor_version, $caller,
1341 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1342 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1343 $longprefix, $bundling_values ];
1344
13451700ns if ( ref($options[0]) eq 'ARRAY' ) {
1346 ( $error, $debug, $major_version, $minor_version, $caller,
1347 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1348 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1349 $longprefix, $bundling_values ) = @{shift(@options)};
1350 }
1351
135210s my $opt;
13531600ns foreach $opt ( @options ) {
1354 my $try = lc ($opt);
1355 my $action = 1;
1356 if ( $try =~ /^no_?(.*)$/s ) {
1357 $action = 0;
1358 $try = $+;
1359 }
1360 if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1361 ConfigDefaults ();
1362 }
1363 elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1364 local $ENV{POSIXLY_CORRECT};
1365 $ENV{POSIXLY_CORRECT} = 1 if $action;
1366 ConfigDefaults ();
1367 }
1368 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1369 $autoabbrev = $action;
1370 }
1371 elsif ( $try eq 'getopt_compat' ) {
1372 $getopt_compat = $action;
1373 $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1374 }
1375 elsif ( $try eq 'gnu_getopt' ) {
1376 if ( $action ) {
1377 $gnu_compat = 1;
1378 $bundling = 1;
1379 $getopt_compat = 0;
1380 $genprefix = "(--|-)";
1381 $order = $PERMUTE;
1382 $bundling_values = 0;
1383 }
1384 }
1385 elsif ( $try eq 'gnu_compat' ) {
1386 $gnu_compat = $action;
1387 $bundling = 0;
1388 $bundling_values = 1;
1389 }
1390 elsif ( $try =~ /^(auto_?)?version$/ ) {
1391 $auto_version = $action;
1392 }
1393 elsif ( $try =~ /^(auto_?)?help$/ ) {
1394 $auto_help = $action;
1395 }
1396 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1397 $ignorecase = $action;
1398 }
1399 elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1400 $ignorecase = $action ? 2 : 0;
1401 }
1402 elsif ( $try eq 'bundling' ) {
1403 $bundling = $action;
1404 $bundling_values = 0 if $action;
1405 }
1406 elsif ( $try eq 'bundling_override' ) {
1407 $bundling = $action ? 2 : 0;
1408 $bundling_values = 0 if $action;
1409 }
1410 elsif ( $try eq 'bundling_values' ) {
1411 $bundling_values = $action;
1412 $bundling = 0 if $action;
1413 }
1414 elsif ( $try eq 'require_order' ) {
1415 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1416 }
1417 elsif ( $try eq 'permute' ) {
1418 $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1419 }
1420 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1421 $passthrough = $action;
1422 }
1423 elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1424 $genprefix = $1;
1425 # Turn into regexp. Needs to be parenthesized!
1426 $genprefix = "(" . quotemeta($genprefix) . ")";
1427 eval { '' =~ /$genprefix/; };
1428 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1429 }
1430 elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1431 $genprefix = $1;
1432 # Parenthesize if needed.
1433 $genprefix = "(" . $genprefix . ")"
1434 unless $genprefix =~ /^\(.*\)$/;
1435 eval { '' =~ m"$genprefix"; };
1436 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1437 }
1438 elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1439 $longprefix = $1;
1440 # Parenthesize if needed.
1441 $longprefix = "(" . $longprefix . ")"
1442 unless $longprefix =~ /^\(.*\)$/;
1443 eval { '' =~ m"$longprefix"; };
1444 die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
1445 }
1446 elsif ( $try eq 'debug' ) {
1447 $debug = $action;
1448 }
1449 else {
1450 die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
1451 }
1452 }
145313µs $prevconfig;
1454}
1455
1456# Deprecated name.
1457sub config (@) {
1458 Configure (@_);
1459}
1460
1461# Issue a standard message for --version.
1462#
1463# The arguments are mostly the same as for Pod::Usage::pod2usage:
1464#
1465# - a number (exit value)
1466# - a string (lead in message)
1467# - a hash with options. See Pod::Usage for details.
1468#
1469sub VersionMessage(@) {
1470 # Massage args.
1471 my $pa = setup_pa_args("version", @_);
1472
1473 my $v = $main::VERSION;
1474 my $fh = $pa->{-output} ||
1475 ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );
1476
1477 print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1478 $0, defined $v ? " version $v" : (),
1479 "\n",
1480 "(", __PACKAGE__, "::", "GetOptions",
1481 " version ",
1482 defined($Getopt::Long::VERSION_STRING)
1483 ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1484 " Perl version ",
1485 $] >= 5.006 ? sprintf("%vd", $^V) : $],
1486 ")\n");
1487 exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1488}
1489
1490# Issue a standard message for --help.
1491#
1492# The arguments are the same as for Pod::Usage::pod2usage:
1493#
1494# - a number (exit value)
1495# - a string (lead in message)
1496# - a hash with options. See Pod::Usage for details.
1497#
1498sub HelpMessage(@) {
1499 eval {
1500 require Pod::Usage;
1501 import Pod::Usage;
1502 1;
1503 } || die("Cannot provide help: cannot load Pod::Usage\n");
1504
1505 # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1506 pod2usage(setup_pa_args("help", @_));
1507
1508}
1509
1510# Helper routine to set up a normalized hash ref to be used as
1511# argument to pod2usage.
1512sub setup_pa_args($@) {
1513 my $tag = shift; # who's calling
1514
1515 # If called by direct binding to an option, it will get the option
1516 # name and value as arguments. Remove these, if so.
1517 @_ = () if @_ == 2 && $_[0] eq $tag;
1518
1519 my $pa;
1520 if ( @_ > 1 ) {
1521 $pa = { @_ };
1522 }
1523 else {
1524 $pa = shift || {};
1525 }
1526
1527 # At this point, $pa can be a number (exit value), string
1528 # (message) or hash with options.
1529
1530 if ( UNIVERSAL::isa($pa, 'HASH') ) {
1531 # Get rid of -msg vs. -message ambiguity.
1532 $pa->{-message} = $pa->{-msg};
1533 delete($pa->{-msg});
1534 }
1535 elsif ( $pa =~ /^-?\d+$/ ) {
1536 $pa = { -exitval => $pa };
1537 }
1538 else {
1539 $pa = { -message => $pa };
1540 }
1541
1542 # These are _our_ defaults.
1543 $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1544 $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1545 $pa;
1546}
1547
1548# Sneak way to know what version the user requested.
1549sub VERSION {
1550 $requested_version = $_[1];
1551 shift->SUPER::VERSION(@_);
1552}
1553
1554package Getopt::Long::CallBack;
1555
1556sub new {
1557 my ($pkg, %atts) = @_;
1558 bless { %atts }, $pkg;
1559}
1560
1561sub name {
1562 my $self = shift;
1563 ''.$self->{name};
1564}
1565
1566use overload
1567 # Treat this object as an ordinary string for legacy API.
1568110µs144µs
# spent 60µs (16+44) within Getopt::Long::CallBack::BEGIN@1568 which was called: # once (16µs+44µs) by main::BEGIN@8 at line 1569
'""' => \&name,
# spent 44µs making 1 call to overload::import
1569190µs160µs fallback => 1;
# spent 60µs making 1 call to Getopt::Long::CallBack::BEGIN@1568
1570
1571112µs1;
1572
1573################ Documentation ################
1574
 
# spent 135µs within Getopt::Long::CORE:match which was called 175 times, avg 769ns/call: # 66 times (8µs+0s) by Getopt::Long::FindOption at line 1012, avg 121ns/call # 27 times (43µs+0s) by Getopt::Long::ParseOptionSpec at line 804, avg 2µs/call # 27 times (17µs+0s) by Getopt::Long::GetOptionsFromArray at line 364, avg 615ns/call # 24 times (30µs+0s) by Getopt::Long::ParseOptionSpec at line 866, avg 1µs/call # 24 times (5µs+0s) by Getopt::Long::ParseOptionSpec at line 850, avg 192ns/call # 3 times (4µs+0s) by Getopt::Long::FindOption at line 935, avg 1µs/call # 2 times (2µs+0s) by Getopt::Long::FindOption at line 948, avg 750ns/call # once (24µs+0s) by main::BEGIN@8 at line 129 # once (2µs+0s) by Getopt::Long::GetOptionsFromArray at line 342
sub Getopt::Long::CORE:match; # opcode
# spent 91µs within Getopt::Long::CORE:regcomp which was called 98 times, avg 929ns/call: # 66 times (24µs+0s) by Getopt::Long::FindOption at line 1012, avg 362ns/call # 27 times (45µs+0s) by Getopt::Long::GetOptionsFromArray at line 364, avg 2µs/call # 3 times (16µs+0s) by Getopt::Long::FindOption at line 935, avg 5µs/call # 2 times (6µs+0s) by Getopt::Long::FindOption at line 948, avg 3µs/call
sub Getopt::Long::CORE:regcomp; # opcode
# spent 13µs within Getopt::Long::CORE:sort which was called 2 times, avg 6µs/call: # 2 times (13µs+0s) by Getopt::Long::FindOption at line 1005, avg 6µs/call
sub Getopt::Long::CORE:sort; # opcode
# spent 700ns within main::CORE:subst which was called: # once (700ns+0s) by main::set_options at line 107 of /root/tor-browser-build/rbm/rbm
sub main::CORE:subst; # opcode
# spent 2µs within main::__ANON__ which was called: # once (2µs+0s) by main::BEGIN@6 at line 6 of /root/tor-browser-build/rbm/rbm
sub main::__ANON__; # xsub
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.