← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/usr/lib/x86_64-linux-gnu/perl-base/Getopt/Long.pm
StatementsExecuted 694 statements in 5.72ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11177µs272µsGetopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
51160µs86µsGetopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
61154µs74µsGetopt::Long::::FindOption Getopt::Long::FindOption
3410145µs45µsGetopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
163133µs33µsGetopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
22116µs18µsGetopt::Long::::Configure Getopt::Long::Configure
11113µs13µsmain::::BEGIN@13 main::BEGIN@13
11111µs88µsGetopt::Long::::import Getopt::Long::import
1118µs30µsGetopt::Long::CallBack::::BEGIN@1573Getopt::Long::CallBack::BEGIN@1573
1116µs36µsGetopt::Long::::BEGIN@220 Getopt::Long::BEGIN@220
1115µs7µsmain::::BEGIN@15.7 main::BEGIN@15.7
1115µs41µsGetopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1114µs19µsGetopt::Long::::BEGIN@20 Getopt::Long::BEGIN@20
1114µs20µsGetopt::Long::::BEGIN@230 Getopt::Long::BEGIN@230
1114µs23µsmain::::BEGIN@16.8 main::BEGIN@16.8
1114µs4µsGetopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
1114µs4µsGetopt::Long::::GetOptions Getopt::Long::GetOptions
1114µs10µsGetopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1113µs20µsGetopt::Long::::BEGIN@234 Getopt::Long::BEGIN@234
1113µs10µsGetopt::Long::::BEGIN@23 Getopt::Long::BEGIN@23
1113µs15µsGetopt::Long::::BEGIN@248 Getopt::Long::BEGIN@248
1113µs29µsGetopt::Long::::BEGIN@49 Getopt::Long::BEGIN@49
1113µs17µsGetopt::Long::::BEGIN@232 Getopt::Long::BEGIN@232
1113µs16µsGetopt::Long::::BEGIN@249 Getopt::Long::BEGIN@249
1113µs3µsGetopt::Long::::BEGIN@38 Getopt::Long::BEGIN@38
1113µs15µsGetopt::Long::::BEGIN@237 Getopt::Long::BEGIN@237
1113µs16µsGetopt::Long::::BEGIN@259 Getopt::Long::BEGIN@259
1113µs18µsGetopt::Long::::BEGIN@47 Getopt::Long::BEGIN@47
1113µs14µsGetopt::Long::::BEGIN@235 Getopt::Long::BEGIN@235
1113µs14µsGetopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1113µs14µsGetopt::Long::::BEGIN@241 Getopt::Long::BEGIN@241
1113µs15µsGetopt::Long::::BEGIN@238 Getopt::Long::BEGIN@238
1113µs15µsGetopt::Long::::BEGIN@240 Getopt::Long::BEGIN@240
1113µs18µsGetopt::Long::::BEGIN@27 Getopt::Long::BEGIN@27
1112µs24µsGetopt::Long::::BEGIN@52 Getopt::Long::BEGIN@52
0000s0sGetopt::Long::CallBack::::givenGetopt::Long::CallBack::given
0000s0sGetopt::Long::CallBack::::nameGetopt::Long::CallBack::name
0000s0sGetopt::Long::CallBack::::newGetopt::Long::CallBack::new
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
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: Tue Aug 18 14:48:05 2020
8# Update Count : 1739
9# Status : Released
10
11################ Module Preamble ################
12
13230µs113µs
# spent 13µs within main::BEGIN@13 which was called: # once (13µs+0s) by main::BEGIN@32 at line 13
use 5.004;
# spent 13µs making 1 call to main::BEGIN@13
14
15216µs29µs
# spent 7µs (5+2) within main::BEGIN@15.7 which was called: # once (5µs+2µs) by main::BEGIN@32 at line 15
use strict;
# spent 7µs making 1 call to main::BEGIN@15.7 # spent 2µs making 1 call to strict::import
16222µs241µs
# spent 23µs (4+19) within main::BEGIN@16.8 which was called: # once (4µs+19µs) by main::BEGIN@32 at line 16
use warnings;
# spent 23µs making 1 call to main::BEGIN@16.8 # spent 19µs making 1 call to warnings::import
17
18package Getopt::Long;
19
20222µs233µs
# spent 19µs (4+14) within Getopt::Long::BEGIN@20 which was called: # once (4µs+14µs) by main::BEGIN@32 at line 20
use vars qw($VERSION);
# spent 19µs making 1 call to Getopt::Long::BEGIN@20 # spent 14µs making 1 call to vars::import
211200ns$VERSION = 2.52;
22# For testing versions only.
23215µs218µs
# spent 10µs (3+7) within Getopt::Long::BEGIN@23 which was called: # once (3µs+7µs) by main::BEGIN@32 at line 23
use vars qw($VERSION_STRING);
# spent 10µs making 1 call to Getopt::Long::BEGIN@23 # spent 7µs making 1 call to vars::import
241300ns$VERSION_STRING = "2.52";
25
26214µs216µs
# spent 10µs (4+6) within Getopt::Long::BEGIN@26 which was called: # once (4µs+6µs) by main::BEGIN@32 at line 26
use Exporter;
# spent 10µs making 1 call to Getopt::Long::BEGIN@26 # spent 6µs making 1 call to Exporter::import
27254µs234µs
# spent 18µs (3+16) within Getopt::Long::BEGIN@27 which was called: # once (3µs+16µs) by main::BEGIN@32 at line 27
use vars qw(@ISA @EXPORT @EXPORT_OK);
# spent 18µs making 1 call to Getopt::Long::BEGIN@27 # spent 16µs making 1 call to vars::import
2817µ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 3µs within Getopt::Long::BEGIN@38 which was called: # once (3µs+0s) by main::BEGIN@32 at line 43
BEGIN {
39 # Init immediately so their contents can be used in the 'use vars' below.
401700ns @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
4112µs @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
42 &GetOptionsFromArray &GetOptionsFromString);
43118µs13µs}
# spent 3µs making 1 call to Getopt::Long::BEGIN@38
44
45# User visible variables.
46216µs278µs
# spent 41µs (5+36) within Getopt::Long::BEGIN@46 which was called: # once (5µs+36µs) by main::BEGIN@32 at line 46
use vars @EXPORT, @EXPORT_OK;
# spent 41µs making 1 call to Getopt::Long::BEGIN@46 # spent 36µs making 1 call to vars::import
47219µs234µs
# spent 18µs (3+16) within Getopt::Long::BEGIN@47 which was called: # once (3µs+16µs) by main::BEGIN@32 at line 47
use vars qw($error $debug $major_version $minor_version);
# spent 18µs making 1 call to Getopt::Long::BEGIN@47 # spent 16µs making 1 call to vars::import
48# Deprecated visible variables.
4912µs126µs
# spent 29µs (3+26) within Getopt::Long::BEGIN@49 which was called: # once (3µs+26µs) by main::BEGIN@32 at line 50
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
# spent 26µs making 1 call to vars::import
50113µs129µs $passthrough);
# spent 29µs making 1 call to Getopt::Long::BEGIN@49
51# Official invisible variables.
522431µs246µs
# spent 24µs (2+22) within Getopt::Long::BEGIN@52 which was called: # once (2µs+22µs) by main::BEGIN@32 at line 52
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# spent 24µs making 1 call to Getopt::Long::BEGIN@52 # spent 22µ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 4µs within Getopt::Long::ConfigDefaults which was called: # once (4µs+0s) by main::BEGIN@32 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 {
861200ns $genprefix = "(--|-|\\+)";
871200ns $autoabbrev = 1; # automatic abbrev of options
881200ns $bundling = 0; # bundling off by default
891100ns $getopt_compat = 1; # allow '+' to start options
901200ns $order = $PERMUTE;
91 }
92 # Other configurable settings.
931200ns $debug = 0; # for debugging
941200ns $error = 0; # error tally
951200ns $ignorecase = 1; # ignore case when matching options
961100ns $passthrough = 0; # leave unrecognized options alone
971100ns $gnu_compat = 0; # require --opt=val if value is optional
981200ns $longprefix = "(--)"; # what does a long prefix look like
9912µs $bundling_values = 0; # no bundling of values
100}
101
102# Override import.
103
# spent 88µs (11+77) within Getopt::Long::import which was called: # once (11µs+77µs) by main::BEGIN@32 at line 32 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl
sub import {
1041400ns my $pkg = shift; # package
1051300ns my @syms = (); # symbols to import
1061200ns my @config = (); # configuration
1071200ns my $dest = \@syms; # symbols first
1081600ns for ( @_ ) {
1093700ns if ( $_ eq ':config' ) {
1101200ns $dest = \@config; # config next
1111200ns next;
112 }
1132600ns push(@$dest, $_); # push
114 }
115 # Hide one level and call super.
1161400ns local $Exporter::ExportLevel = 1;
1171100ns push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
1181100ns $requested_version = 0;
11913µs164µs $pkg->SUPER::import(@syms);
# spent 64µs making 1 call to Exporter::import
120 # And configure.
12113µs113µs Configure(@config) if @config;
# spent 13µs making 1 call to Getopt::Long::Configure
122}
123
124################ Initialization ################
125
126# Values for $order. See GNU getopt.c for details.
1271400ns($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
128# Version major/minor numbers.
129113µs19µs($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
# spent 9µs making 1 call to Getopt::Long::CORE:match
130
1311800ns14µsConfigDefaults();
# spent 4µ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.
1391700ns15µsmy $default_config = do {
# spent 5µ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'.
220221µs267µs
# spent 36µs (6+31) within Getopt::Long::BEGIN@220 which was called: # once (6µs+31µs) by main::BEGIN@32 at line 220
use constant CTL_TYPE => 0;
# spent 36µs making 1 call to Getopt::Long::BEGIN@220 # spent 31µ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
230218µs236µs
# spent 20µs (4+16) within Getopt::Long::BEGIN@230 which was called: # once (4µs+16µs) by main::BEGIN@32 at line 230
use constant CTL_CNAME => 1;
# spent 20µs making 1 call to Getopt::Long::BEGIN@230 # spent 16µs making 1 call to constant::import
231
232214µs231µs
# spent 17µs (3+14) within Getopt::Long::BEGIN@232 which was called: # once (3µs+14µs) by main::BEGIN@32 at line 232
use constant CTL_DEFAULT => 2;
# spent 17µs making 1 call to Getopt::Long::BEGIN@232 # spent 14µs making 1 call to constant::import
233
234213µs237µs
# spent 20µs (3+17) within Getopt::Long::BEGIN@234 which was called: # once (3µs+17µs) by main::BEGIN@32 at line 234
use constant CTL_DEST => 3;
# spent 20µs making 1 call to Getopt::Long::BEGIN@234 # spent 17µs making 1 call to constant::import
235212µs226µs
# spent 14µs (3+12) within Getopt::Long::BEGIN@235 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 235
use constant CTL_DEST_SCALAR => 0;
# spent 14µs making 1 call to Getopt::Long::BEGIN@235 # spent 12µs making 1 call to constant::import
236212µs226µs
# spent 14µs (3+12) within Getopt::Long::BEGIN@236 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 236
use constant CTL_DEST_ARRAY => 1;
# spent 14µs making 1 call to Getopt::Long::BEGIN@236 # spent 12µs making 1 call to constant::import
237219µs226µs
# spent 15µs (3+12) within Getopt::Long::BEGIN@237 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 237
use constant CTL_DEST_HASH => 2;
# spent 15µs making 1 call to Getopt::Long::BEGIN@237 # spent 12µs making 1 call to constant::import
238212µs227µs
# spent 15µs (3+12) within Getopt::Long::BEGIN@238 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 238
use constant CTL_DEST_CODE => 3;
# spent 15µs making 1 call to Getopt::Long::BEGIN@238 # spent 12µs making 1 call to constant::import
239
240211µs227µs
# spent 15µs (3+12) within Getopt::Long::BEGIN@240 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 240
use constant CTL_AMIN => 4;
# spent 15µs making 1 call to Getopt::Long::BEGIN@240 # spent 12µs making 1 call to constant::import
241217µs226µs
# spent 14µs (3+12) within Getopt::Long::BEGIN@241 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 241
use constant CTL_AMAX => 5;
# spent 14µs making 1 call to Getopt::Long::BEGIN@241 # spent 12µ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.
248228µs228µs
# spent 15µs (3+12) within Getopt::Long::BEGIN@248 which was called: # once (3µs+12µs) by main::BEGIN@32 at line 248
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
# spent 15µs making 1 call to Getopt::Long::BEGIN@248 # spent 12µs making 1 call to constant::import
24912µs113µs
# spent 16µs (3+13) within Getopt::Long::BEGIN@249 which was called: # once (3µs+13µs) by main::BEGIN@32 at line 258
use constant PAT_XINT =>
# spent 13µ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_]*".
258122µs116µs ")";
# spent 16µs making 1 call to Getopt::Long::BEGIN@249
25912µs113µs
# spent 16µs (3+13) within Getopt::Long::BEGIN@259 which was called: # once (3µs+13µs) by main::BEGIN@32 at line 264
use constant PAT_FLOAT =>
# spent 13µ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
26414.46ms116µs "([eE][-+]?[0-9_]+)?"; # optional exponent
# spent 16µs making 1 call to Getopt::Long::BEGIN@259
265
266
# spent 4µs within Getopt::Long::GetOptions which was called: # once (4µs+0s) by main::RUNTIME at line 54 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl
sub GetOptions(@) {
267 # Shift in default array.
26811µs unshift(@_, \@ARGV);
269 # Try to keep caller() and Carp consistent.
27014µs1272µs goto &GetOptionsFromArray;
# spent 272µs making 1 call to Getopt::Long::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 272µs (77+195) within Getopt::Long::GetOptionsFromArray which was called: # once (77µs+195µs) by main::RUNTIME at line 270
sub GetOptionsFromArray(@) {
288
28912µs my ($argv, @optionlist) = @_; # local copy of the option descriptions
2901300ns my $argend = '--'; # option list terminator
2911300ns my %opctl = (); # table of option specs
29212µs113µs my $pkg = $caller || (caller)[0]; # current context
# spent 13µs making 1 call to Contextual::Return::__ANON__[Contextual/Return.pm:30]
293 # Needed if linkage is omitted.
2941300ns my @ret = (); # accum for non-options
2951300ns my %linkage; # linkage
296 my $userlinkage; # user supplied HASH
297 my $opt; # current option
2981300ns my $prefix = $genprefix; # current prefix
299
3001500ns $error = '';
301
3021200ns if ( $debug ) {
303 # Avoid some warnings if debugging.
304 local ($^W) = 0;
305 print STDERR
306 ("Getopt::Long $Getopt::Long::VERSION_STRING ",
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.
3321300ns $userlinkage = undef;
33314µs1700ns if ( @optionlist && ref($optionlist[0]) and
# spent 700ns making 1 call to UNIVERSAL::isa
334 UNIVERSAL::isa($optionlist[0],'HASH') ) {
3351300ns $userlinkage = shift (@optionlist);
3361300ns 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.
34214µs13µs if ( @optionlist && $optionlist[0] =~ /^\W+$/
# spent 3µ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.
3541300ns %opctl = ();
3551800ns while ( @optionlist ) {
3565700ns my $opt = shift (@optionlist);
357
3585600ns 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.
364527µs1019µs $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
# spent 16µs making 5 calls to Getopt::Long::CORE:regcomp, avg 3µs/call # spent 3µs making 5 calls to Getopt::Long::CORE:match, avg 580ns/call
365
3665600ns 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.
38655µs586µs my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
# spent 86µs making 5 calls to Getopt::Long::ParseOptionSpec, avg 17µs/call
3875600ns 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.
3985400ns if ( defined $userlinkage ) {
39951µs unless ( @optionlist > 0 && ref($optionlist[0]) ) {
4005800ns 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.
40953µ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
47512µs1600ns $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
# spent 600ns making 1 call to UNIVERSAL::isa
476 unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );
477
478 # Bail out if errors found.
4791200ns die ($error) if $error;
4801400ns $error = 0;
481
482 # Supply --version and --help support, if needed and allowed.
4831500ns if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
4841700ns if ( !defined($opctl{version}) ) {
48511µs $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
4861600ns $linkage{version} = \&VersionMessage;
487 }
4881200ns $auto_version = 1;
489 }
4901900ns 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.
4991300ns 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
5091500ns my $goon = 1;
5101700ns while ( $goon && @$argv > 0 ) {
511
512 # Get next argument.
51361µs $opt = shift (@$argv);
5146400ns print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
515
516 # Double dash is option list terminator.
51761µs if ( defined($opt) && $opt eq $argend ) {
518 push (@ret, $argend) if $passthrough;
519 last;
520 }
521
522 # Look it up.
5236700ns my $tryopt = $opt;
5246700ns my $found; # success status
525 my $key; # key (if hash type)
526 my $arg; # option argument
527 my $ctl; # the opctl entry
528
52966µs674µs ($found, $opt, $ctl, $arg, $key) =
# spent 74µs making 6 calls to Getopt::Long::FindOption, avg 12µs/call
530 FindOption ($argv, $prefix, $argend, $opt, \%opctl);
531
53262µs if ( $found ) {
533
534 # FindOption undefines $opt in case of errors.
5355500ns next unless defined $opt;
536
5375500ns my $argcnt = 0;
5385500ns while ( defined $arg ) {
539
540 # Get the canonical name.
5415300ns my $given = $opt;
5425400ns print STDERR ("=> cname for \"$opt\" is ") if $debug;
5435700ns $opt = $ctl->[CTL_CNAME];
5445500ns print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
545
54652µs if ( defined $linkage{$opt} ) {
547 print STDERR ("=> ref(\$L{$opt}) -> ",
548 ref($linkage{$opt}), "\n") if $debug;
549
550 if ( ref($linkage{$opt}) eq 'SCALAR'
551 || ref($linkage{$opt}) eq 'REF' ) {
552 if ( $ctl->[CTL_TYPE] eq '+' ) {
553 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
554 if $debug;
555 if ( defined ${$linkage{$opt}} ) {
556 ${$linkage{$opt}} += $arg;
557 }
558 else {
559 ${$linkage{$opt}} = $arg;
560 }
561 }
562 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
563 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
564 " to ARRAY\n")
565 if $debug;
566 my $t = $linkage{$opt};
567 $$t = $linkage{$opt} = [];
568 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
569 if $debug;
570 push (@{$linkage{$opt}}, $arg);
571 }
572 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
573 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
574 " to HASH\n")
575 if $debug;
576 my $t = $linkage{$opt};
577 $$t = $linkage{$opt} = {};
578 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
579 if $debug;
580 $linkage{$opt}->{$key} = $arg;
581 }
582 else {
583 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
584 if $debug;
585 ${$linkage{$opt}} = $arg;
586 }
587 }
588 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
589 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
590 if $debug;
591 push (@{$linkage{$opt}}, $arg);
592 }
593 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
594 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
595 if $debug;
596 $linkage{$opt}->{$key} = $arg;
597 }
598 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
599 print STDERR ("=> &L{$opt}(\"$opt\"",
600 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
601 ", \"$arg\")\n")
602 if $debug;
603 my $eval_error = do {
604 local $@;
605 local $SIG{__DIE__} = 'DEFAULT';
606 eval {
607 &{$linkage{$opt}}
608 (Getopt::Long::CallBack->new
609 (name => $opt,
610 given => $given,
611 ctl => $ctl,
612 opctl => \%opctl,
613 linkage => \%linkage,
614 prefix => $prefix,
615 ),
616 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
617 $arg);
618 };
619 $@;
620 };
621 print STDERR ("=> die($eval_error)\n")
622 if $debug && $eval_error ne '';
623 if ( $eval_error =~ /^!/ ) {
624 if ( $eval_error =~ /^!FINISH\b/ ) {
625 $goon = 0;
626 }
627 }
628 elsif ( $eval_error ne '' ) {
629 warn ($eval_error);
630 $error++;
631 }
632 }
633 else {
634 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
635 "\" in linkage\n");
636 die("Getopt::Long -- internal error!\n");
637 }
638 }
639 # No entry in linkage means entry in userlinkage.
640 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
64151µs if ( defined $userlinkage->{$opt} ) {
6422200ns print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
643 if $debug;
64421µs push (@{$userlinkage->{$opt}}, $arg);
645 }
646 else {
6473300ns print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
648 if $debug;
64931µs $userlinkage->{$opt} = [$arg];
650 }
651 }
652 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
653 if ( defined $userlinkage->{$opt} ) {
654 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
655 if $debug;
656 $userlinkage->{$opt}->{$key} = $arg;
657 }
658 else {
659 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
660 if $debug;
661 $userlinkage->{$opt} = {$key => $arg};
662 }
663 }
664 else {
665 if ( $ctl->[CTL_TYPE] eq '+' ) {
666 print STDERR ("=> \$L{$opt} += \"$arg\"\n")
667 if $debug;
668 if ( defined $userlinkage->{$opt} ) {
669 $userlinkage->{$opt} += $arg;
670 }
671 else {
672 $userlinkage->{$opt} = $arg;
673 }
674 }
675 else {
676 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
677 $userlinkage->{$opt} = $arg;
678 }
679 }
680
6815500ns $argcnt++;
68252µs last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
683 undef($arg);
684
685 # Need more args?
686 if ( $argcnt < $ctl->[CTL_AMIN] ) {
687 if ( @$argv ) {
688 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
689 $arg = shift(@$argv);
690 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
691 $arg =~ tr/_//d;
692 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
693 ? oct($arg)
694 : 0+$arg
695 }
696 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
697 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
698 next;
699 }
700 warn("Value \"$$argv[0]\" invalid for option $opt\n");
701 $error++;
702 }
703 else {
704 warn("Insufficient arguments for option $opt\n");
705 $error++;
706 }
707 }
708
709 # Any more args?
710 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
711 $arg = shift(@$argv);
712 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
713 $arg =~ tr/_//d;
714 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
715 ? oct($arg)
716 : 0+$arg
717 }
718 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
719 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
720 next;
721 }
722 }
723 }
724
725 # Not an option. Save it if we $PERMUTE and don't have a <>.
726 elsif ( $order == $PERMUTE ) {
727 # Try non-options call-back.
7281400ns my $cb;
7291600ns if ( defined ($cb = $linkage{'<>'}) ) {
730 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
731 if $debug;
732 my $eval_error = do {
733 local $@;
734 local $SIG{__DIE__} = 'DEFAULT';
735 eval {
736 # The arg to <> cannot be the CallBack object
737 # since it may be passed to other modules that
738 # get confused (e.g., Archive::Tar). Well,
739 # it's not relevant for this callback anyway.
740 &$cb($tryopt);
741 };
742 $@;
743 };
744 print STDERR ("=> die($eval_error)\n")
745 if $debug && $eval_error ne '';
746 if ( $eval_error =~ /^!/ ) {
747 if ( $eval_error =~ /^!FINISH\b/ ) {
748 $goon = 0;
749 }
750 }
751 elsif ( $eval_error ne '' ) {
752 warn ($eval_error);
753 $error++;
754 }
755 }
756 else {
7571100ns print STDERR ("=> saving \"$tryopt\" ",
758 "(not an option, may permute)\n") if $debug;
7591300ns push (@ret, $tryopt);
760 }
7611400ns next;
762 }
763
764 # ...otherwise, terminate.
765 else {
766 # Push this one back and exit.
767 unshift (@$argv, $tryopt);
768 return ($error == 0);
769 }
770
771 }
772
773 # Finish.
7741700ns if ( @ret && ( $order == $PERMUTE || $passthrough ) ) {
775 # Push back accumulated arguments
77610s print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
777 if $debug;
7781500ns unshift (@$argv, @ret);
779 }
780
78116µs return ($error == 0);
782}
783
784# A readable representation of what's in an optbl.
785sub OptCtl ($) {
786 my ($v) = @_;
787 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
788 "[".
789 join(",",
790 "\"$v[CTL_TYPE]\"",
791 "\"$v[CTL_CNAME]\"",
792 "\"$v[CTL_DEFAULT]\"",
793 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
794 $v[CTL_AMIN] || '',
795 $v[CTL_AMAX] || '',
796# $v[CTL_RANGE] || '',
797# $v[CTL_REPEAT] || '',
798 ). "]";
799}
800
801# Parse an option specification and fill the tables.
802
# spent 86µs (60+26) within Getopt::Long::ParseOptionSpec which was called 5 times, avg 17µs/call: # 5 times (60µs+26µs) by Getopt::Long::GetOptionsFromArray at line 386, avg 17µs/call
sub ParseOptionSpec ($$) {
80351µs my ($opt, $opctl) = @_;
804
805 # Match option spec.
806527µs521µs if ( $opt !~ m;^
# spent 21µs making 5 calls to Getopt::Long::CORE:match, avg 4µs/call
807 (
808 # Option name
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
82754µs my ($names, $spec) = ($1, $2);
8285800ns $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.
8365500ns my $orig;
837
838 my @names;
8395900ns if ( defined $names ) {
84053µs @names = split (/\|/, $names);
8415900ns $orig = $names[0];
842 }
843 else {
844 @names = ('');
845 $orig = '';
846 }
847
848 # Construct the opctl entries.
8495300ns my $entry;
85056µs4400ns if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# spent 400ns making 4 calls to Getopt::Long::CORE:match, avg 100ns/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 {
86649µs45µs my ($mand, $type, $dest) =
# spent 5µs making 4 calls to Getopt::Long::CORE:match, avg 1µs/call
867 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
86841µs return (undef, "Cannot repeat while bundling: \"$opt\"\n")
869 if $bundling && defined($4);
87042µs my ($mi, $cm, $ma) = ($5, $6, $7);
8714600ns return (undef, "{0} is useless in option spec: \"$opt\"\n")
872 if defined($mi) && !$mi && !defined($ma) && !defined($cm);
873
8744500ns $type = 'i' if $type eq 'n';
8754500ns $dest ||= '$';
87641µ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.
8794900ns $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
880 # Adjust mand status according to minargs.
8814500ns $mand = $mi ? '=' : ':';
882 # Adjust maxargs.
8834700ns $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
8844500ns return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
885 if defined($ma) && !$ma;
8864600ns return (undef, "Max less than min in option spec: \"$opt\"\n")
887 if defined($ma) && $ma < $mi;
888
889 # Fields are hard-wired here.
89042µs $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
891 }
892
893 # Process all names. First is canonical, the rest are aliases.
8945600ns my $dups = '';
89551µs foreach ( @names ) {
896
897134µs $_ = lc ($_)
898 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
899
900132µs if ( exists $opctl->{$_} ) {
901 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
902 }
903
904133µs if ( $spec eq '!' ) {
905 $opctl->{"no$_"} = $entry;
906 $opctl->{"no-$_"} = $entry;
907 $opctl->{$_} = [@$entry];
908 $opctl->{$_}->[CTL_TYPE] = '';
909 }
910 else {
911134µs $opctl->{$_} = $entry;
912 }
913 }
914
9155600ns if ( $dups && $^W ) {
916 foreach ( split(/\n+/, $dups) ) {
917 warn($_."\n");
918 }
919 }
92058µs ($names[0], $orig);
921}
922
923# Option lookup.
924
# spent 74µs (54+20) within Getopt::Long::FindOption which was called 6 times, avg 12µs/call: # 6 times (54µs+20µs) by Getopt::Long::GetOptionsFromArray at line 529, avg 12µ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
93061µs my ($argv, $prefix, $argend, $opt, $opctl) = @_;
931
9326400ns print STDERR ("=> find \"$opt\"\n") if $debug;
933
9346700ns return (0) unless defined($opt);
935624µs1215µs return (0) unless $opt =~ /^($prefix)(.*)$/s;
# spent 12µs making 6 calls to Getopt::Long::CORE:regcomp, avg 2µs/call # spent 3µs making 6 calls to Getopt::Long::CORE:match, avg 467ns/call
9365800ns return (0) if $opt eq "-" && !defined $opctl->{''};
937
93852µs $opt = substr( $opt, length($1) ); # retain taintedness
93951µs my $starter = $1;
940
9415300ns print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
942
9435500ns 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.
948511µs105µs if ( ($starter=~/^$longprefix$/
# spent 5µs making 5 calls to Getopt::Long::CORE:regcomp, avg 980ns/call # spent 100ns making 5 calls to Getopt::Long::CORE:match, avg 20ns/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
9605700ns my $tryopt = $opt; # option to try
961
96251µs if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
963
964 # To try overrides, obey case ignore.
96551µs $tryopt = $ignorecase ? lc($opt) : $opt;
966
967 # If bundling == 2, long options can override bundles.
96851µs 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 {
9915500ns $tryopt = $opt;
992 # Unbundle single letter option.
99351µs $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
99451µs $tryopt = substr ($tryopt, 0, 1);
9955500ns $tryopt = lc ($tryopt) if $ignorecase > 1;
9965500ns print STDERR ("=> $starter$tryopt unbundled from ",
997 "$starter$tryopt$rest\n") if $debug;
99851µs $rest = undef unless $rest ne '';
999 }
1000 }
1001
1002 # Try auto-abbreviation.
1003 elsif ( $autoabbrev && $opt ne "" ) {
1004 # Sort the possible long option names.
1005 my @names = sort(keys (%$opctl));
1006 # Downcase if allowed.
1007 $opt = lc ($opt) if $ignorecase;
1008 $tryopt = $opt;
1009 # Turn option name into pattern.
1010 my $pat = quotemeta ($opt);
1011 # Look up in option names.
1012 my @hits = grep (/^$pat/, @names);
1013 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1014 "out of ", scalar(@names), "\n") if $debug;
1015
1016 # Check for ambiguous results.
1017 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.
1047 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.
106252µs my $ctl = $opctl->{$tryopt};
10635500ns 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.
10805500ns $opt = $tryopt;
10815400ns 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.
108751µs my $type = $ctl->[CTL_TYPE];
10885300ns my $arg;
1089
109051µ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.
11115800ns my $mand = $ctl->[CTL_AMIN];
1112
1113 # Check if there is an option argument available.
11145800ns if ( $gnu_compat ) {
11155400ns my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux
111652µs 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 }
11255600ns 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 }
11385600ns 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.
114351µ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 || $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
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.
116652µ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.
11705400ns my $key;
11715500ns 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
118651µs my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1187
11885700ns if ( $type eq 's' ) { # string
1189 # A mandatory string takes anything.
119058µ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 18µs (16+2) within Getopt::Long::Configure which was called 2 times, avg 9µs/call: # once (11µs+2µs) by Getopt::Long::import at line 121 # once (5µs+0s) by main::BEGIN@32 at line 139
sub Configure (@) {
13372900ns my (@options) = @_;
1338
133923µ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
13452700ns 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
13522300ns my $opt;
135321µs foreach $opt ( @options ) {
13542900ns my $try = lc ($opt);
13552200ns my $action = 1;
135622µs2500ns if ( $try =~ /^no_?(.*)$/s ) {
# spent 500ns making 2 calls to Getopt::Long::CORE:match, avg 250ns/call
1357 $action = 0;
1358 $try = $+;
1359 }
136025µs11µs if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
# spent 1µs making 1 call to Getopt::Long::CORE:match
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' ) {
13761300ns if ( $action ) {
13771100ns $gnu_compat = 1;
13781100ns $bundling = 1;
13791100ns $getopt_compat = 0;
13801200ns $genprefix = "(--|-)";
13811100ns $order = $PERMUTE;
13821100ns $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$/ ) {
13911200ns $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 }
145325µ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] if @_ > 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
1566sub given {
1567 my $self = shift;
1568 $self->{given};
1569}
1570
1571use overload
1572 # Treat this object as an ordinary string for legacy API.
157315µs122µs
# spent 30µs (8+22) within Getopt::Long::CallBack::BEGIN@1573 which was called: # once (8µs+22µs) by main::BEGIN@32 at line 1574
'""' => \&name,
# spent 22µs making 1 call to overload::import
1574147µs130µs fallback => 1;
# spent 30µs making 1 call to Getopt::Long::CallBack::BEGIN@1573
1575
1576111µs1;
1577
1578################ Documentation ################
1579
 
# spent 45µs within Getopt::Long::CORE:match which was called 34 times, avg 1µs/call: # 6 times (3µs+0s) by Getopt::Long::FindOption at line 935, avg 467ns/call # 5 times (21µs+0s) by Getopt::Long::ParseOptionSpec at line 806, avg 4µs/call # 5 times (3µs+0s) by Getopt::Long::GetOptionsFromArray at line 364, avg 580ns/call # 5 times (100ns+0s) by Getopt::Long::FindOption at line 948, avg 20ns/call # 4 times (5µs+0s) by Getopt::Long::ParseOptionSpec at line 866, avg 1µs/call # 4 times (400ns+0s) by Getopt::Long::ParseOptionSpec at line 850, avg 100ns/call # 2 times (500ns+0s) by Getopt::Long::Configure at line 1356, avg 250ns/call # once (9µs+0s) by main::BEGIN@32 at line 129 # once (3µs+0s) by Getopt::Long::GetOptionsFromArray at line 342 # once (1µs+0s) by Getopt::Long::Configure at line 1360
sub Getopt::Long::CORE:match; # opcode
# spent 33µs within Getopt::Long::CORE:regcomp which was called 16 times, avg 2µs/call: # 6 times (12µs+0s) by Getopt::Long::FindOption at line 935, avg 2µs/call # 5 times (16µs+0s) by Getopt::Long::GetOptionsFromArray at line 364, avg 3µs/call # 5 times (5µs+0s) by Getopt::Long::FindOption at line 948, avg 980ns/call
sub Getopt::Long::CORE:regcomp; # opcode
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.