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

Filename/usr/share/perl/5.18/Getopt/Long.pm
StatementsExecuted 1488 statements in 8.53ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
2411741µs910µsGetopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
321550µs1.78msGetopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
120111272µs272µsGetopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
762177µs203µsGetopt::Long::::Configure Getopt::Long::Configure
3241126µs126µsGetopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
411121µs198µsGetopt::Long::::FindOption Getopt::Long::FindOption
11150µs149µsGetopt::Long::Parser::::new Getopt::Long::Parser::new
11144µs1.55msGetopt::Long::Parser::::getoptionsfromarray Getopt::Long::Parser::getoptionsfromarray
11117µs17µsGetopt::Long::::BEGIN@15 Getopt::Long::BEGIN@15
11113µs1.57msGetopt::Long::Parser::::getoptions Getopt::Long::Parser::getoptions
11112µs148µsGetopt::Long::::import Getopt::Long::import
11111µs45µsGetopt::Long::CallBack::::BEGIN@1506Getopt::Long::CallBack::BEGIN@1506
11110µs27µsGetopt::Long::::BEGIN@243 Getopt::Long::BEGIN@243
1119µs45µsGetopt::Long::::BEGIN@215 Getopt::Long::BEGIN@215
1119µs25µsGetopt::Long::::BEGIN@25 Getopt::Long::BEGIN@25
1119µs19µsGetopt::Long::::VERSION Getopt::Long::VERSION
2118µs8µsGetopt::Long::::GetOptions Getopt::Long::GetOptions
1117µs15µsGetopt::Long::::BEGIN@17 Getopt::Long::BEGIN@17
1117µs28µsGetopt::Long::::BEGIN@225 Getopt::Long::BEGIN@225
1116µs54µsGetopt::Long::::BEGIN@48 Getopt::Long::BEGIN@48
1116µs26µsGetopt::Long::::BEGIN@19 Getopt::Long::BEGIN@19
1116µs38µsGetopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1116µs25µsGetopt::Long::::BEGIN@232 Getopt::Long::BEGIN@232
1116µs25µsGetopt::Long::::BEGIN@229 Getopt::Long::BEGIN@229
1116µs28µsGetopt::Long::::BEGIN@230 Getopt::Long::BEGIN@230
1115µs44µsGetopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1115µs25µsGetopt::Long::::BEGIN@244 Getopt::Long::BEGIN@244
1115µs24µsGetopt::Long::::BEGIN@254 Getopt::Long::BEGIN@254
1115µs20µsGetopt::Long::::BEGIN@22 Getopt::Long::BEGIN@22
1115µs25µsGetopt::Long::::BEGIN@227 Getopt::Long::BEGIN@227
1115µs23µsGetopt::Long::::BEGIN@235 Getopt::Long::BEGIN@235
1115µs81µsGetopt::Long::::BEGIN@45 Getopt::Long::BEGIN@45
1115µs22µsGetopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1115µs23µsGetopt::Long::::BEGIN@231 Getopt::Long::BEGIN@231
1115µs23µsGetopt::Long::::BEGIN@233 Getopt::Long::BEGIN@233
1114µs52µsGetopt::Long::::BEGIN@51 Getopt::Long::BEGIN@51
1114µs4µsGetopt::Long::::BEGIN@37 Getopt::Long::BEGIN@37
1114µs4µsGetopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
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::::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 Mar 12 14:42:25 2013
8# Update Count : 1638
9# Status : Released
10
11################ Module Preamble ################
12
13package Getopt::Long;
14
15244µs117µs
# spent 17µs within Getopt::Long::BEGIN@15 which was called: # once (17µs+0s) by Getopt::Long::Descriptive::BEGIN@8 at line 15
use 5.004;
# spent 17µs making 1 call to Getopt::Long::BEGIN@15
16
17221µs224µs
# spent 15µs (7+9) within Getopt::Long::BEGIN@17 which was called: # once (7µs+9µs) by Getopt::Long::Descriptive::BEGIN@8 at line 17
use strict;
# spent 15µs making 1 call to Getopt::Long::BEGIN@17 # spent 9µs making 1 call to strict::import
18
19228µs246µs
# spent 26µs (6+20) within Getopt::Long::BEGIN@19 which was called: # once (6µs+20µs) by Getopt::Long::Descriptive::BEGIN@8 at line 19
use vars qw($VERSION);
# spent 26µs making 1 call to Getopt::Long::BEGIN@19 # spent 20µs making 1 call to vars::import
201300ns$VERSION = 2.39;
21# For testing versions only.
22224µs234µs
# spent 20µs (5+15) within Getopt::Long::BEGIN@22 which was called: # once (5µs+15µs) by Getopt::Long::Descriptive::BEGIN@8 at line 22
use vars qw($VERSION_STRING);
# spent 20µs making 1 call to Getopt::Long::BEGIN@22 # spent 15µs making 1 call to vars::import
231300ns$VERSION_STRING = "2.39";
24
25223µs241µs
# spent 25µs (9+16) within Getopt::Long::BEGIN@25 which was called: # once (9µs+16µs) by Getopt::Long::Descriptive::BEGIN@8 at line 25
use Exporter;
# spent 25µs making 1 call to Getopt::Long::BEGIN@25 # spent 16µs making 1 call to Exporter::import
26266µs270µs
# spent 38µs (6+32) within Getopt::Long::BEGIN@26 which was called: # once (6µs+32µs) by Getopt::Long::Descriptive::BEGIN@8 at line 26
use vars qw(@ISA @EXPORT @EXPORT_OK);
# spent 38µs making 1 call to Getopt::Long::BEGIN@26 # spent 32µs making 1 call to vars::import
2717µs@ISA = qw(Exporter);
28
29# Exported subroutines.
30sub GetOptions(@); # always
31sub GetOptionsFromArray(@); # on demand
32sub GetOptionsFromString(@); # on demand
33sub Configure(@); # on demand
34sub HelpMessage(@); # on demand
35sub VersionMessage(@); # in demand
36
37
# spent 4µs within Getopt::Long::BEGIN@37 which was called: # once (4µs+0s) by Getopt::Long::Descriptive::BEGIN@8 at line 42
BEGIN {
38 # Init immediately so their contents can be used in the 'use vars' below.
3911µs @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
4014µs @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
41 &GetOptionsFromArray &GetOptionsFromString);
42119µs14µs}
# spent 4µs making 1 call to Getopt::Long::BEGIN@37
43
44# User visible variables.
45222µs2156µs
# spent 81µs (5+76) within Getopt::Long::BEGIN@45 which was called: # once (5µs+76µs) by Getopt::Long::Descriptive::BEGIN@8 at line 45
use vars @EXPORT, @EXPORT_OK;
# spent 81µs making 1 call to Getopt::Long::BEGIN@45 # spent 76µs making 1 call to vars::import
46224µs283µs
# spent 44µs (5+39) within Getopt::Long::BEGIN@46 which was called: # once (5µs+39µs) by Getopt::Long::Descriptive::BEGIN@8 at line 46
use vars qw($error $debug $major_version $minor_version);
# spent 44µs making 1 call to Getopt::Long::BEGIN@46 # spent 39µs making 1 call to vars::import
47# Deprecated visible variables.
4813µs147µs
# spent 54µs (6+47) within Getopt::Long::BEGIN@48 which was called: # once (6µs+47µs) by Getopt::Long::Descriptive::BEGIN@8 at line 49
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
# spent 47µs making 1 call to vars::import
49120µs154µs $passthrough);
# spent 54µs making 1 call to Getopt::Long::BEGIN@48
50# Official invisible variables.
512499µs2100µs
# spent 52µs (4+48) within Getopt::Long::BEGIN@51 which was called: # once (4µs+48µs) by Getopt::Long::Descriptive::BEGIN@8 at line 51
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# spent 52µs making 1 call to Getopt::Long::BEGIN@51 # spent 48µs making 1 call to vars::import
52
53# Public subroutines.
54sub config(@); # deprecated name
55
56# Private subroutines.
57sub ConfigDefaults();
58sub ParseOptionSpec($$);
59sub OptCtl($);
60sub FindOption($$$$$);
61sub ValidValue ($$$$$);
62
63################ Local Variables ################
64
65# $requested_version holds the version that was mentioned in the 'use'
66# or 'require', if any. It can be used to enable or disable specific
67# features.
681200nsmy $requested_version = 0;
69
70################ Resident subroutines ################
71
72
# spent 4µs within Getopt::Long::ConfigDefaults which was called: # once (4µs+0s) by Getopt::Long::Descriptive::BEGIN@8 at line 126
sub ConfigDefaults() {
73 # Handle POSIX compliancy.
7411µs if ( defined $ENV{"POSIXLY_CORRECT"} ) {
75 $genprefix = "(--|-)";
76 $autoabbrev = 0; # no automatic abbrev of options
77 $bundling = 0; # no bundling of single letter switches
78 $getopt_compat = 0; # disallow '+' to start options
79 $order = $REQUIRE_ORDER;
80 }
81 else {
821300ns $genprefix = "(--|-|\\+)";
831200ns $autoabbrev = 1; # automatic abbrev of options
841100ns $bundling = 0; # bundling off by default
851100ns $getopt_compat = 1; # allow '+' to start options
861200ns $order = $PERMUTE;
87 }
88 # Other configurable settings.
891200ns $debug = 0; # for debugging
901100ns $error = 0; # error tally
911100ns $ignorecase = 1; # ignore case when matching options
921100ns $passthrough = 0; # leave unrecognized options alone
931100ns $gnu_compat = 0; # require --opt=val if value is optional
9413µs $longprefix = "(--)"; # what does a long prefix look like
95}
96
97# Override import.
98
# spent 148µs (12+136) within Getopt::Long::import which was called: # once (12µs+136µs) by Getopt::Long::Descriptive::BEGIN@8 at line 8 of Getopt/Long/Descriptive.pm
sub import {
991500ns my $pkg = shift; # package
1001300ns my @syms = (); # symbols to import
1011400ns my @config = (); # configuration
1021500ns my $dest = \@syms; # symbols first
1031700ns for ( @_ ) {
104 if ( $_ eq ':config' ) {
105 $dest = \@config; # config next
106 next;
107 }
108 push(@$dest, $_); # push
109 }
110 # Hide one level and call super.
1111900ns local $Exporter::ExportLevel = 1;
1121300ns push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
1131200ns $requested_version = 0;
11413µs1136µs $pkg->SUPER::import(@syms);
# spent 136µs making 1 call to Exporter::import
115 # And configure.
11613µs Configure(@config) if @config;
117}
118
119################ Initialization ################
120
121# Values for $order. See GNU getopt.c for details.
1221700ns($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
123# Version major/minor numbers.
124114µs18µs($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
# spent 8µs making 1 call to Getopt::Long::CORE:match
125
12611µs14µsConfigDefaults();
# spent 4µs making 1 call to Getopt::Long::ConfigDefaults
127
128################ OO Interface ################
129
130package Getopt::Long::Parser;
131
132# Store a copy of the default configuration. Since ConfigDefaults has
133# just been called, what we get from Configure is the default.
1341900ns14µsmy $default_config = do {
# spent 4µs making 1 call to Getopt::Long::Configure
135 Getopt::Long::Configure ()
136};
137
138
# spent 149µs (50+99) within Getopt::Long::Parser::new which was called: # once (50µs+99µs) by Plack::Runner::parse_options at line 38 of Plack/Runner.pm
sub new {
1391800ns my $that = shift;
14011µs my $class = ref($that) || $that;
14113µs my %atts = @_;
142
143 # Register the callers package.
14415µs my $self = { caller_pkg => (caller)[0] };
145
14612µs bless ($self, $class);
147
148 # Process config attributes.
14912µs if ( defined $atts{config} ) {
15015µs185µs my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
# spent 85µs making 1 call to Getopt::Long::Configure
151115µs114µs $self->{settings} = Getopt::Long::Configure ($save);
# spent 14µs making 1 call to Getopt::Long::Configure
15215µs delete ($atts{config});
153 }
154 # Else use default config.
155 else {
156 $self->{settings} = $default_config;
157 }
158
1591900ns if ( %atts ) { # Oops
160 die(__PACKAGE__.": unhandled attributes: ".
161 join(" ", sort(keys(%atts)))."\n");
162 }
163
16418µs $self;
165}
166
167sub configure {
168 my ($self) = shift;
169
170 # Restore settings, merge new settings in.
171 my $save = Getopt::Long::Configure ($self->{settings}, @_);
172
173 # Restore orig config and save the new config.
174 $self->{settings} = Getopt::Long::Configure ($save);
175}
176
177
# spent 1.57ms (13µs+1.55) within Getopt::Long::Parser::getoptions which was called: # once (13µs+1.55ms) by Plack::Runner::parse_options at line 56 of Plack/Runner.pm
sub getoptions {
17812µs my ($self) = shift;
179
180110µs11.55ms return $self->getoptionsfromarray(\@ARGV, @_);
# spent 1.55ms making 1 call to Getopt::Long::Parser::getoptionsfromarray
181}
182
183
# spent 1.55ms (44µs+1.51) within Getopt::Long::Parser::getoptionsfromarray which was called: # once (44µs+1.51ms) by Getopt::Long::Parser::getoptions at line 180
sub getoptionsfromarray {
18412µs my ($self) = shift;
185
186 # Restore config settings.
18712µs113µs my $save = Getopt::Long::Configure ($self->{settings});
# spent 13µs making 1 call to Getopt::Long::Configure
188
189 # Call main routine.
1901600ns my $ret = 0;
19112µs $Getopt::Long::caller = $self->{caller_pkg};
192
19311µs eval {
194 # Locally set exception handler to default, otherwise it will
195 # be called implicitly here, and again explicitly when we try
196 # to deliver the messages.
19717µs local ($SIG{__DIE__}) = 'DEFAULT';
19819µs11.48ms $ret = Getopt::Long::GetOptionsFromArray (@_);
# spent 1.48ms making 1 call to Getopt::Long::GetOptionsFromArray
199 };
200
201 # Restore saved settings.
20213µs116µs Getopt::Long::Configure ($save);
# spent 16µs making 1 call to Getopt::Long::Configure
203
204 # Handle errors and return value.
2051500ns die ($@) if $@;
20618µs return $ret;
207}
208
209package Getopt::Long;
210
211################ Back to Normal ################
212
213# Indices in option control info.
214# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
215227µs280µs
# spent 45µs (9+36) within Getopt::Long::BEGIN@215 which was called: # once (9µs+36µs) by Getopt::Long::Descriptive::BEGIN@8 at line 215
use constant CTL_TYPE => 0;
# spent 45µs making 1 call to Getopt::Long::BEGIN@215 # spent 36µs making 1 call to constant::import
216#use constant CTL_TYPE_FLAG => '';
217#use constant CTL_TYPE_NEG => '!';
218#use constant CTL_TYPE_INCR => '+';
219#use constant CTL_TYPE_INT => 'i';
220#use constant CTL_TYPE_INTINC => 'I';
221#use constant CTL_TYPE_XINT => 'o';
222#use constant CTL_TYPE_FLOAT => 'f';
223#use constant CTL_TYPE_STRING => 's';
224
225221µs249µs
# spent 28µs (7+21) within Getopt::Long::BEGIN@225 which was called: # once (7µs+21µs) by Getopt::Long::Descriptive::BEGIN@8 at line 225
use constant CTL_CNAME => 1;
# spent 28µs making 1 call to Getopt::Long::BEGIN@225 # spent 21µs making 1 call to constant::import
226
227219µs244µs
# spent 25µs (5+20) within Getopt::Long::BEGIN@227 which was called: # once (5µs+20µs) by Getopt::Long::Descriptive::BEGIN@8 at line 227
use constant CTL_DEFAULT => 2;
# spent 25µs making 1 call to Getopt::Long::BEGIN@227 # spent 20µs making 1 call to constant::import
228
229222µs244µs
# spent 25µs (6+20) within Getopt::Long::BEGIN@229 which was called: # once (6µs+20µs) by Getopt::Long::Descriptive::BEGIN@8 at line 229
use constant CTL_DEST => 3;
# spent 25µs making 1 call to Getopt::Long::BEGIN@229 # spent 20µs making 1 call to constant::import
230220µs250µs
# spent 28µs (6+22) within Getopt::Long::BEGIN@230 which was called: # once (6µs+22µs) by Getopt::Long::Descriptive::BEGIN@8 at line 230
use constant CTL_DEST_SCALAR => 0;
# spent 28µs making 1 call to Getopt::Long::BEGIN@230 # spent 22µs making 1 call to constant::import
231222µs242µs
# spent 23µs (5+18) within Getopt::Long::BEGIN@231 which was called: # once (5µs+18µs) by Getopt::Long::Descriptive::BEGIN@8 at line 231
use constant CTL_DEST_ARRAY => 1;
# spent 23µs making 1 call to Getopt::Long::BEGIN@231 # spent 18µs making 1 call to constant::import
232218µs244µs
# spent 25µs (6+19) within Getopt::Long::BEGIN@232 which was called: # once (6µs+19µs) by Getopt::Long::Descriptive::BEGIN@8 at line 232
use constant CTL_DEST_HASH => 2;
# spent 25µs making 1 call to Getopt::Long::BEGIN@232 # spent 19µs making 1 call to constant::import
233221µs241µs
# spent 23µs (5+18) within Getopt::Long::BEGIN@233 which was called: # once (5µs+18µs) by Getopt::Long::Descriptive::BEGIN@8 at line 233
use constant CTL_DEST_CODE => 3;
# spent 23µs making 1 call to Getopt::Long::BEGIN@233 # spent 18µs making 1 call to constant::import
234
235219µs241µs
# spent 23µs (5+18) within Getopt::Long::BEGIN@235 which was called: # once (5µs+18µs) by Getopt::Long::Descriptive::BEGIN@8 at line 235
use constant CTL_AMIN => 4;
# spent 23µs making 1 call to Getopt::Long::BEGIN@235 # spent 18µs making 1 call to constant::import
236221µs240µs
# spent 22µs (5+17) within Getopt::Long::BEGIN@236 which was called: # once (5µs+17µs) by Getopt::Long::Descriptive::BEGIN@8 at line 236
use constant CTL_AMAX => 5;
# spent 22µs making 1 call to Getopt::Long::BEGIN@236 # spent 17µs making 1 call to constant::import
237
238# FFU.
239#use constant CTL_RANGE => ;
240#use constant CTL_REPEAT => ;
241
242# Rather liberal patterns to match numbers.
243239µs244µs
# spent 27µs (10+17) within Getopt::Long::BEGIN@243 which was called: # once (10µs+17µs) by Getopt::Long::Descriptive::BEGIN@8 at line 243
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
# spent 27µs making 1 call to Getopt::Long::BEGIN@243 # spent 17µs making 1 call to constant::import
24413µs120µs
# spent 25µs (5+20) within Getopt::Long::BEGIN@244 which was called: # once (5µs+20µs) by Getopt::Long::Descriptive::BEGIN@8 at line 253
use constant PAT_XINT =>
# spent 20µs making 1 call to constant::import
245 "(?:".
246 "[-+]?_*[1-9][0-9_]*".
247 "|".
248 "0x_*[0-9a-f][0-9a-f_]*".
249 "|".
250 "0b_*[01][01_]*".
251 "|".
252 "0[0-7_]*".
253121µs125µs ")";
# spent 25µs making 1 call to Getopt::Long::BEGIN@244
25425.24ms242µs
# spent 24µs (5+18) within Getopt::Long::BEGIN@254 which was called: # once (5µs+18µs) by Getopt::Long::Descriptive::BEGIN@8 at line 254
use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
# spent 24µs making 1 call to Getopt::Long::BEGIN@254 # spent 18µs making 1 call to constant::import
255
256
# spent 8µs within Getopt::Long::GetOptions which was called 2 times, avg 4µs/call: # 2 times (8µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 430 of Getopt/Long/Descriptive.pm, avg 4µs/call
sub GetOptions(@) {
257 # Shift in default array.
25823µs unshift(@_, \@ARGV);
259 # Try to keep caller() and Carp consistent.
26028µs2297µs goto &GetOptionsFromArray;
# spent 297µs making 2 calls to Getopt::Long::GetOptionsFromArray, avg 149µs/call
261}
262
263sub GetOptionsFromString(@) {
264 my ($string) = shift;
265 require Text::ParseWords;
266 my $args = [ Text::ParseWords::shellwords($string) ];
267 $caller ||= (caller)[0]; # current context
268 my $ret = GetOptionsFromArray($args, @_);
269 return ( $ret, $args ) if wantarray;
270 if ( @$args ) {
271 $ret = 0;
272 warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
273 }
274 $ret;
275}
276
277
# spent 1.78ms (550µs+1.23) within Getopt::Long::GetOptionsFromArray which was called 3 times, avg 593µs/call: # 2 times (110µs+188µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 260, avg 149µs/call # once (441µs+1.04ms) by Getopt::Long::Parser::getoptionsfromarray at line 198
sub GetOptionsFromArray(@) {
278
279312µs my ($argv, @optionlist) = @_; # local copy of the option descriptions
28031µs my $argend = '--'; # option list terminator
28132µs my %opctl = (); # table of option specs
28233µs my $pkg = $caller || (caller)[0]; # current context
283 # Needed if linkage is omitted.
28431µs my @ret = (); # accum for non-options
2853500ns my %linkage; # linkage
2863700ns my $userlinkage; # user supplied HASH
2873500ns my $opt; # current option
28832µs my $prefix = $genprefix; # current prefix
289
29031µs $error = '';
291
2923800ns if ( $debug ) {
293 # Avoid some warnings if debugging.
294 local ($^W) = 0;
295 print STDERR
296 ("Getopt::Long $Getopt::Long::VERSION ",
297 "called from package \"$pkg\".",
298 "\n ",
299 "argv: (@$argv)",
300 "\n ",
301 "autoabbrev=$autoabbrev,".
302 "bundling=$bundling,",
303 "getopt_compat=$getopt_compat,",
304 "gnu_compat=$gnu_compat,",
305 "order=$order,",
306 "\n ",
307 "ignorecase=$ignorecase,",
308 "requested_version=$requested_version,",
309 "passthrough=$passthrough,",
310 "genprefix=\"$genprefix\",",
311 "longprefix=\"$longprefix\".",
312 "\n");
313 }
314
315 # Check for ref HASH as first argument.
316 # First argument may be an object. It's OK to use this as long
317 # as it is really a hash underneath.
31832µs $userlinkage = undef;
319311µs22µs if ( @optionlist && ref($optionlist[0]) and
# spent 2µs making 2 calls to UNIVERSAL::isa, avg 1µs/call
320 UNIVERSAL::isa($optionlist[0],'HASH') ) {
3212700ns $userlinkage = shift (@optionlist);
32221µs print STDERR ("=> user linkage: $userlinkage\n") if $debug;
323 }
324
325 # See if the first element of the optionlist contains option
326 # starter characters.
327 # Be careful not to interpret '<>' as option starters.
328317µs37µs if ( @optionlist && $optionlist[0] =~ /^\W+$/
# spent 7µs making 3 calls to Getopt::Long::CORE:match, avg 2µs/call
329 && !($optionlist[0] eq '<>'
330 && @optionlist > 0
331 && ref($optionlist[1])) ) {
332 $prefix = shift (@optionlist);
333 # Turn into regexp. Needs to be parenthesized!
334 $prefix =~ s/(\W)/\\$1/g;
335 $prefix = "([" . $prefix . "])";
336 print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
337 }
338
339 # Verify correctness of optionlist.
34032µs %opctl = ();
34133µs while ( @optionlist ) {
3422412µs my $opt = shift (@optionlist);
343
344246µs unless ( defined($opt) ) {
345 $error .= "Undefined argument in option spec\n";
346 next;
347 }
348
349 # Strip leading prefix so people can specify "--foo=i" if they like.
35024244µs48111µs $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
# spent 62µs making 24 calls to Getopt::Long::CORE:regcomp, avg 3µs/call # spent 49µs making 24 calls to Getopt::Long::CORE:match, avg 2µs/call
351
352248µs if ( $opt eq '<>' ) {
353 if ( (defined $userlinkage)
354 && !(@optionlist > 0 && ref($optionlist[0]))
355 && (exists $userlinkage->{$opt})
356 && ref($userlinkage->{$opt}) ) {
357 unshift (@optionlist, $userlinkage->{$opt});
358 }
359 unless ( @optionlist > 0
360 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
361 $error .= "Option spec <> requires a reference to a subroutine\n";
362 # Kill the linkage (to avoid another error).
363 shift (@optionlist)
364 if @optionlist && ref($optionlist[0]);
365 next;
366 }
367 $linkage{'<>'} = shift (@optionlist);
368 next;
369 }
370
371 # Parse option spec.
3722467µs24910µs my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
# spent 910µs making 24 calls to Getopt::Long::ParseOptionSpec, avg 38µs/call
373248µs unless ( defined $name ) {
374 # Failed. $orig contains the error message. Sorry for the abuse.
375 $error .= $orig;
376 # Kill the linkage (to avoid another error).
377 shift (@optionlist)
378 if @optionlist && ref($optionlist[0]);
379 next;
380 }
381
382 # If no linkage is supplied in the @optionlist, copy it from
383 # the userlinkage if available.
384246µs if ( defined $userlinkage ) {
38552µs unless ( @optionlist > 0 && ref($optionlist[0]) ) {
38651µs if ( exists $userlinkage->{$orig} &&
387 ref($userlinkage->{$orig}) ) {
388 print STDERR ("=> found userlinkage for \"$orig\": ",
389 "$userlinkage->{$orig}\n")
390 if $debug;
391 unshift (@optionlist, $userlinkage->{$orig});
392 }
393 else {
394 # Do nothing. Being undefined will be handled later.
39553µs next;
396 }
397 }
398 }
399
400 # Copy the linkage. If omitted, link to global variable.
4011923µs if ( @optionlist > 0 && ref($optionlist[0]) ) {
402194µs print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
403 if $debug;
4041929µs my $rl = ref($linkage{$orig} = shift (@optionlist));
405
4061922µs if ( $rl eq "ARRAY" ) {
407 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
408 }
409 elsif ( $rl eq "HASH" ) {
410 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
411 }
412 elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
413# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
414# my $t = $linkage{$orig};
415# $$t = $linkage{$orig} = [];
416# }
417# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
418# }
419# else {
420 # Ok.
421# }
422 }
423 elsif ( $rl eq "CODE" ) {
424 # Ok.
425 }
426 else {
427 $error .= "Invalid option linkage for \"$opt\"\n";
428 }
429 }
430 else {
431 # Link to global $opt_XXX variable.
432 # Make sure a valid perl identifier results.
433 my $ov = $orig;
434 $ov =~ s/\W/_/g;
435 if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
436 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
437 if $debug;
438 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
439 }
440 elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
441 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
442 if $debug;
443 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
444 }
445 else {
446 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
447 if $debug;
448 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
449 }
450 }
451
4521935µs if ( $opctl{$name}[CTL_TYPE] eq 'I'
453 && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
454 || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
455 ) {
456 $error .= "Invalid option linkage for \"$opt\"\n";
457 }
458
459 }
460
461 # Bail out if errors found.
4623800ns die ($error) if $error;
46332µs $error = 0;
464
465 # Supply --version and --help support, if needed and allowed.
46633µs if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
467 if ( !defined($opctl{version}) ) {
468 $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
469 $linkage{version} = \&VersionMessage;
470 }
471 $auto_version = 1;
472 }
47333µs if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
474 if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
475 $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
476 $linkage{help} = \&HelpMessage;
477 }
478 $auto_help = 1;
479 }
480
481 # Show the options tables if debugging.
48231µs if ( $debug ) {
483 my ($arrow, $k, $v);
484 $arrow = "=> ";
485 while ( ($k,$v) = each(%opctl) ) {
486 print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
487 $arrow = " ";
488 }
489 }
490
491 # Process argument list
49231µs my $goon = 1;
49334µs while ( $goon && @$argv > 0 ) {
494
495 # Get next argument.
49643µs $opt = shift (@$argv);
4974800ns print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
498
499 # Double dash is option list terminator.
50042µs if ( defined($opt) && $opt eq $argend ) {
501 push (@ret, $argend) if $passthrough;
502 last;
503 }
504
505 # Look it up.
50641µs my $tryopt = $opt;
50741µs my $found; # success status
5084600ns my $key; # key (if hash type)
5094600ns my $arg; # option argument
5104400ns my $ctl; # the opctl entry
511
512413µs4198µs ($found, $opt, $ctl, $arg, $key) =
# spent 198µs making 4 calls to Getopt::Long::FindOption, avg 50µs/call
513 FindOption ($argv, $prefix, $argend, $opt, \%opctl);
514
51546µs if ( $found ) {
516
517 # FindOption undefines $opt in case of errors.
5182500ns next unless defined $opt;
519
5202800ns my $argcnt = 0;
52121µs while ( defined $arg ) {
522
523 # Get the canonical name.
52421µs print STDERR ("=> cname for \"$opt\" is ") if $debug;
52522µs $opt = $ctl->[CTL_CNAME];
5262700ns print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
527
52823µs if ( defined $linkage{$opt} ) {
5291700ns print STDERR ("=> ref(\$L{$opt}) -> ",
530 ref($linkage{$opt}), "\n") if $debug;
531
53212µs if ( ref($linkage{$opt}) eq 'SCALAR'
533 || ref($linkage{$opt}) eq 'REF' ) {
53413µs if ( $ctl->[CTL_TYPE] eq '+' ) {
535 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
536 if $debug;
537 if ( defined ${$linkage{$opt}} ) {
538 ${$linkage{$opt}} += $arg;
539 }
540 else {
541 ${$linkage{$opt}} = $arg;
542 }
543 }
544 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
545 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
546 " to ARRAY\n")
547 if $debug;
548 my $t = $linkage{$opt};
549 $$t = $linkage{$opt} = [];
550 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
551 if $debug;
552 push (@{$linkage{$opt}}, $arg);
553 }
554 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
555 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
556 " to HASH\n")
557 if $debug;
558 my $t = $linkage{$opt};
559 $$t = $linkage{$opt} = {};
560 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
561 if $debug;
562 $linkage{$opt}->{$key} = $arg;
563 }
564 else {
5651300ns print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
566 if $debug;
56712µs ${$linkage{$opt}} = $arg;
568 }
569 }
570 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
571 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
572 if $debug;
573 push (@{$linkage{$opt}}, $arg);
574 }
575 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
576 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
577 if $debug;
578 $linkage{$opt}->{$key} = $arg;
579 }
580 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
581 print STDERR ("=> &L{$opt}(\"$opt\"",
582 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
583 ", \"$arg\")\n")
584 if $debug;
585 my $eval_error = do {
586 local $@;
587 local $SIG{__DIE__} = 'DEFAULT';
588 eval {
589 &{$linkage{$opt}}
590 (Getopt::Long::CallBack->new
591 (name => $opt,
592 ctl => $ctl,
593 opctl => \%opctl,
594 linkage => \%linkage,
595 prefix => $prefix,
596 ),
597 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
598 $arg);
599 };
600 $@;
601 };
602 print STDERR ("=> die($eval_error)\n")
603 if $debug && $eval_error ne '';
604 if ( $eval_error =~ /^!/ ) {
605 if ( $eval_error =~ /^!FINISH\b/ ) {
606 $goon = 0;
607 }
608 }
609 elsif ( $eval_error ne '' ) {
610 warn ($eval_error);
611 $error++;
612 }
613 }
614 else {
615 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
616 "\" in linkage\n");
617 die("Getopt::Long -- internal error!\n");
618 }
619 }
620 # No entry in linkage means entry in userlinkage.
621 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
622 if ( defined $userlinkage->{$opt} ) {
623 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
624 if $debug;
625 push (@{$userlinkage->{$opt}}, $arg);
626 }
627 else {
628 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
629 if $debug;
630 $userlinkage->{$opt} = [$arg];
631 }
632 }
633 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
634 if ( defined $userlinkage->{$opt} ) {
635 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
636 if $debug;
637 $userlinkage->{$opt}->{$key} = $arg;
638 }
639 else {
640 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
641 if $debug;
642 $userlinkage->{$opt} = {$key => $arg};
643 }
644 }
645 else {
6461700ns if ( $ctl->[CTL_TYPE] eq '+' ) {
647 print STDERR ("=> \$L{$opt} += \"$arg\"\n")
648 if $debug;
649 if ( defined $userlinkage->{$opt} ) {
650 $userlinkage->{$opt} += $arg;
651 }
652 else {
653 $userlinkage->{$opt} = $arg;
654 }
655 }
656 else {
6571200ns print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
6581600ns $userlinkage->{$opt} = $arg;
659 }
660 }
661
6622600ns $argcnt++;
66325µs last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
664 undef($arg);
665
666 # Need more args?
667 if ( $argcnt < $ctl->[CTL_AMIN] ) {
668 if ( @$argv ) {
669 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
670 $arg = shift(@$argv);
671 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
672 $arg =~ tr/_//d;
673 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
674 ? oct($arg)
675 : 0+$arg
676 }
677 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
678 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
679 next;
680 }
681 warn("Value \"$$argv[0]\" invalid for option $opt\n");
682 $error++;
683 }
684 else {
685 warn("Insufficient arguments for option $opt\n");
686 $error++;
687 }
688 }
689
690 # Any more args?
691 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
692 $arg = shift(@$argv);
693 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
694 $arg =~ tr/_//d;
695 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
696 ? oct($arg)
697 : 0+$arg
698 }
699 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
700 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
701 next;
702 }
703 }
704 }
705
706 # Not an option. Save it if we $PERMUTE and don't have a <>.
707 elsif ( $order == $PERMUTE ) {
708 # Try non-options call-back.
7092200ns my $cb;
71022µs if ( (defined ($cb = $linkage{'<>'})) ) {
711 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
712 if $debug;
713 my $eval_error = do {
714 local $@;
715 local $SIG{__DIE__} = 'DEFAULT';
716 eval {
717 # The arg to <> cannot be the CallBack object
718 # since it may be passed to other modules that
719 # get confused (e.g., Archive::Tar). Well,
720 # it's not relevant for this callback anyway.
721 &$cb($tryopt);
722 };
723 $@;
724 };
725 print STDERR ("=> die($eval_error)\n")
726 if $debug && $eval_error ne '';
727 if ( $eval_error =~ /^!/ ) {
728 if ( $eval_error =~ /^!FINISH\b/ ) {
729 $goon = 0;
730 }
731 }
732 elsif ( $eval_error ne '' ) {
733 warn ($eval_error);
734 $error++;
735 }
736 }
737 else {
7382200ns print STDERR ("=> saving \"$tryopt\" ",
739 "(not an option, may permute)\n") if $debug;
7402900ns push (@ret, $tryopt);
741 }
7422900ns next;
743 }
744
745 # ...otherwise, terminate.
746 else {
747 # Push this one back and exit.
748 unshift (@$argv, $tryopt);
749 return ($error == 0);
750 }
751
752 }
753
754 # Finish.
75532µs if ( @ret && $order == $PERMUTE ) {
756 # Push back accumulated arguments
7571200ns print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
758 if $debug;
7591700ns unshift (@$argv, @ret);
760 }
761
762335µs return ($error == 0);
763}
764
765# A readable representation of what's in an optbl.
766sub OptCtl ($) {
767 my ($v) = @_;
768 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
769 "[".
770 join(",",
771 "\"$v[CTL_TYPE]\"",
772 "\"$v[CTL_CNAME]\"",
773 "\"$v[CTL_DEFAULT]\"",
774 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
775 $v[CTL_AMIN] || '',
776 $v[CTL_AMAX] || '',
777# $v[CTL_RANGE] || '',
778# $v[CTL_REPEAT] || '',
779 ). "]";
780}
781
782# Parse an option specification and fill the tables.
783
# spent 910µs (741+169) within Getopt::Long::ParseOptionSpec which was called 24 times, avg 38µs/call: # 24 times (741µs+169µs) by Getopt::Long::GetOptionsFromArray at line 372, avg 38µs/call
sub ParseOptionSpec ($$) {
7842416µs my ($opt, $opctl) = @_;
785
786 # Match option spec.
78724164µs2498µs if ( $opt !~ m;^
# spent 98µs making 24 calls to Getopt::Long::CORE:match, avg 4µs/call
788 (
789 # Option name
790 (?: \w+[-\w]* )
791 # Alias names, or "?"
792 (?: \| (?: \? | \w[-\w]* ) )*
793 # Aliases
794 (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
795 )?
796 (
797 # Either modifiers ...
798 [!+]
799 |
800 # ... or a value/dest/repeat specification
801 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
802 |
803 # ... or an optional-with-default spec
804 : (?: -?\d+ | \+ ) [@%]?
805 )?
806 $;x ) {
807 return (undef, "Error in option spec: \"$opt\"\n");
808 }
809
8102445µs my ($names, $spec) = ($1, $2);
811249µs $spec = '' unless defined $spec;
812
813 # $orig keeps track of the primary name the user specified.
814 # This name will be used for the internal or external linkage.
815 # In other words, if the user specifies "FoO|BaR", it will
816 # match any case combinations of 'foo' and 'bar', but if a global
817 # variable needs to be set, it will be $opt_FoO in the exact case
818 # as specified.
819243µs my $orig;
820
821245µs my @names;
8222412µs if ( defined $names ) {
8232455µs @names = split (/\|/, $names);
8242414µs $orig = $names[0];
825 }
826 else {
827 @names = ('');
828 $orig = '';
829 }
830
831 # Construct the opctl entries.
832245µs my $entry;
8332486µs1610µs if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# spent 10µs making 16 calls to Getopt::Long::CORE:match, avg 600ns/call
834 # Fields are hard-wired here.
835 $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
836 }
837 elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
838 my $def = $1;
839 my $dest = $2;
840 my $type = $def eq '+' ? 'I' : 'i';
841 $dest ||= '$';
842 $dest = $dest eq '@' ? CTL_DEST_ARRAY
843 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
844 # Fields are hard-wired here.
845 $entry = [$type,$orig,$def eq '+' ? undef : $def,
846 $dest,0,1];
847 }
848 else {
84916123µs1661µs my ($mand, $type, $dest) =
# spent 61µs making 16 calls to Getopt::Long::CORE:match, avg 4µs/call
850 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
851164µs return (undef, "Cannot repeat while bundling: \"$opt\"\n")
852 if $bundling && defined($4);
8531625µs my ($mi, $cm, $ma) = ($5, $6, $7);
854165µs return (undef, "{0} is useless in option spec: \"$opt\"\n")
855 if defined($mi) && !$mi && !defined($ma) && !defined($cm);
856
857165µs $type = 'i' if $type eq 'n';
858166µs $dest ||= '$';
8591610µs $dest = $dest eq '@' ? CTL_DEST_ARRAY
860 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
861 # Default minargs to 1/0 depending on mand status.
862168µs $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
863 # Adjust mand status according to minargs.
864165µs $mand = $mi ? '=' : ':';
865 # Adjust maxargs.
866168µs $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
867166µs return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
868 if defined($ma) && !$ma;
869166µs return (undef, "Max less than min in option spec: \"$opt\"\n")
870 if defined($ma) && $ma < $mi;
871
872 # Fields are hard-wired here.
8731641µs $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
874 }
875
876 # Process all names. First is canonical, the rest are aliases.
877248µs my $dups = '';
8782423µs foreach ( @names ) {
879
8804316µs $_ = lc ($_)
881 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
882
8834322µs if ( exists $opctl->{$_} ) {
884 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
885 }
886
8874340µs if ( $spec eq '!' ) {
88815µs $opctl->{"no$_"} = $entry;
88912µs $opctl->{"no-$_"} = $entry;
89013µs $opctl->{$_} = [@$entry];
89111µs $opctl->{$_}->[CTL_TYPE] = '';
892 }
893 else {
8944243µs $opctl->{$_} = $entry;
895 }
896 }
897
898245µs if ( $dups && $^W ) {
899 foreach ( split(/\n+/, $dups) ) {
900 warn($_."\n");
901 }
902 }
90324114µs ($names[0], $orig);
904}
905
906# Option lookup.
907
# spent 198µs (121+77) within Getopt::Long::FindOption which was called 4 times, avg 50µs/call: # 4 times (121µs+77µs) by Getopt::Long::GetOptionsFromArray at line 512, avg 50µs/call
sub FindOption ($$$$$) {
908
909 # returns (1, $opt, $ctl, $arg, $key) if okay,
910 # returns (1, undef) if option in error,
911 # returns (0) otherwise.
912
91343µs my ($argv, $prefix, $argend, $opt, $opctl) = @_;
914
9154900ns print STDERR ("=> find \"$opt\"\n") if $debug;
916
91742µs return (0) unless defined($opt);
918442µs822µs return (0) unless $opt =~ /^($prefix)(.*)$/s;
# spent 13µs making 4 calls to Getopt::Long::CORE:regcomp, avg 3µs/call # spent 9µs making 4 calls to Getopt::Long::CORE:match, avg 2µs/call
91932µs return (0) if $opt eq "-" && !defined $opctl->{''};
920
92136µs $opt = substr( $opt, length($1) ); # retain taintedness
92232µs my $starter = $1;
923
9243600ns print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
925
9263300ns my $optarg; # value supplied with --opt=value
9273400ns my $rest; # remainder from unbundling
928
929 # If it is a long option, it may include the value.
930 # With getopt_compat, only if not bundling.
931324µs68µs if ( ($starter=~/^$longprefix$/
# spent 8µs making 3 calls to Getopt::Long::CORE:regcomp, avg 3µs/call # spent 500ns making 3 calls to Getopt::Long::CORE:match, avg 167ns/call
932 || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
933 && (my $oppos = index($opt, '=', 1)) > 0) {
934 my $optorg = $opt;
935 $opt = substr($optorg, 0, $oppos);
936 $optarg = substr($optorg, $oppos + 1); # retain tainedness
937 print STDERR ("=> option \"", $opt,
938 "\", optarg = \"$optarg\"\n") if $debug;
939 }
940
941 #### Look it up ###
942
94332µs my $tryopt = $opt; # option to try
944
94532µs if ( $bundling && $starter eq '-' ) {
946
947 # To try overrides, obey case ignore.
9482300ns $tryopt = $ignorecase ? lc($opt) : $opt;
949
950 # If bundling == 2, long options can override bundles.
95122µs if ( $bundling == 2 && length($tryopt) > 1
952 && defined ($opctl->{$tryopt}) ) {
953 print STDERR ("=> $starter$tryopt overrides unbundling\n")
954 if $debug;
955 }
956 else {
9572400ns $tryopt = $opt;
958 # Unbundle single letter option.
95922µs $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
9602800ns $tryopt = substr ($tryopt, 0, 1);
9612500ns $tryopt = lc ($tryopt) if $ignorecase > 1;
9622400ns print STDERR ("=> $starter$tryopt unbundled from ",
963 "$starter$tryopt$rest\n") if $debug;
96421µs $rest = undef unless $rest ne '';
965 }
966 }
967
968 # Try auto-abbreviation.
969 elsif ( $autoabbrev && $opt ne "" ) {
970 # Sort the possible long option names.
971 my @names = sort(keys (%$opctl));
972 # Downcase if allowed.
973 $opt = lc ($opt) if $ignorecase;
974 $tryopt = $opt;
975 # Turn option name into pattern.
976 my $pat = quotemeta ($opt);
977 # Look up in option names.
978 my @hits = grep (/^$pat/, @names);
979 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
980 "out of ", scalar(@names), "\n") if $debug;
981
982 # Check for ambiguous results.
983 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
984 # See if all matches are for the same option.
985 my %hit;
986 foreach ( @hits ) {
987 my $hit = $_;
988 $hit = $opctl->{$hit}->[CTL_CNAME]
989 if defined $opctl->{$hit}->[CTL_CNAME];
990 $hit{$hit} = 1;
991 }
992 # Remove auto-supplied options (version, help).
993 if ( keys(%hit) == 2 ) {
994 if ( $auto_version && exists($hit{version}) ) {
995 delete $hit{version};
996 }
997 elsif ( $auto_help && exists($hit{help}) ) {
998 delete $hit{help};
999 }
1000 }
1001 # Now see if it really is ambiguous.
1002 unless ( keys(%hit) == 1 ) {
1003 return (0) if $passthrough;
1004 warn ("Option ", $opt, " is ambiguous (",
1005 join(", ", @hits), ")\n");
1006 $error++;
1007 return (1, undef);
1008 }
1009 @hits = keys(%hit);
1010 }
1011
1012 # Complete the option name, if appropriate.
1013 if ( @hits == 1 && $hits[0] ne $opt ) {
1014 $tryopt = $hits[0];
1015 $tryopt = lc ($tryopt) if $ignorecase;
1016 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1017 if $debug;
1018 }
1019 }
1020
1021 # Map to all lowercase if ignoring case.
1022 elsif ( $ignorecase ) {
1023 $tryopt = lc ($opt);
1024 }
1025
1026 # Check validity by fetching the info.
102732µs my $ctl = $opctl->{$tryopt};
102831µs unless ( defined $ctl ) {
102913µs return (0) if $passthrough;
1030 # Pretend one char when bundling.
1031 if ( $bundling == 1 && length($starter) == 1 ) {
1032 $opt = substr($opt,0,1);
1033 unshift (@$argv, $starter.$rest) if defined $rest;
1034 }
1035 if ( $opt eq "" ) {
1036 warn ("Missing option after ", $starter, "\n");
1037 }
1038 else {
1039 warn ("Unknown option: ", $opt, "\n");
1040 }
1041 $error++;
1042 return (1, undef);
1043 }
1044 # Apparently valid.
10452700ns $opt = $tryopt;
10462500ns print STDERR ("=> found ", OptCtl($ctl),
1047 " for \"", $opt, "\"\n") if $debug;
1048
1049 #### Determine argument status ####
1050
1051 # If it is an option w/o argument, we're almost finished with it.
105221µs my $type = $ctl->[CTL_TYPE];
10532400ns my $arg;
1054
105522µs if ( $type eq '' || $type eq '!' || $type eq '+' ) {
105611µs if ( defined $optarg ) {
1057 return (0) if $passthrough;
1058 warn ("Option ", $opt, " does not take an argument\n");
1059 $error++;
1060 undef $opt;
1061 }
1062 elsif ( $type eq '' || $type eq '+' ) {
1063 # Supply explicit value.
1064 $arg = 1;
1065 }
1066 else {
1067 $opt =~ s/^no-?//i; # strip NO prefix
1068 $arg = 0; # supply explicit value
1069 }
10701200ns unshift (@$argv, $starter.$rest) if defined $rest;
107113µs return (1, $opt, $ctl, $arg);
1072 }
1073
1074 # Get mandatory status and type info.
10751900ns my $mand = $ctl->[CTL_AMIN];
1076
1077 # Check if there is an option argument available.
10781400ns if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
1079 return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
1080 $optarg = 0 unless $type eq 's';
1081 }
1082
1083 # Check if there is an option argument available.
108412µs if ( defined $optarg
1085 ? ($optarg eq '')
1086 : !(defined $rest || @$argv > 0) ) {
1087 # Complain if this option needs an argument.
1088# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1089 if ( $mand ) {
1090 return (0) if $passthrough;
1091 warn ("Option ", $opt, " requires an argument\n");
1092 $error++;
1093 return (1, undef);
1094 }
1095 if ( $type eq 'I' ) {
1096 # Fake incremental type.
1097 my @c = @$ctl;
1098 $c[CTL_TYPE] = '+';
1099 return (1, $opt, \@c, 1);
1100 }
1101 return (1, $opt, $ctl,
1102 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1103 $type eq 's' ? '' : 0);
1104 }
1105
1106 # Get (possibly optional) argument.
110712µs $arg = (defined $rest ? $rest
1108 : (defined $optarg ? $optarg : shift (@$argv)));
1109
1110 # Get key if this is a "name=value" pair for a hash option.
111111µs my $key;
11121800ns if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1113 ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1114 : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1115 ($mand ? undef : ($type eq 's' ? "" : 1)));
1116 if (! defined $arg) {
1117 warn ("Option $opt, key \"$key\", requires a value\n");
1118 $error++;
1119 # Push back.
1120 unshift (@$argv, $starter.$rest) if defined $rest;
1121 return (1, undef);
1122 }
1123 }
1124
1125 #### Check if the argument is valid for this option ####
1126
112712µs my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1128
112913µs if ( $type eq 's' ) { # string
1130 # A mandatory string takes anything.
1131 return (1, $opt, $ctl, $arg, $key) if $mand;
1132
1133 # Same for optional string as a hash value
1134 return (1, $opt, $ctl, $arg, $key)
1135 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1136
1137 # An optional string takes almost anything.
1138 return (1, $opt, $ctl, $arg, $key)
1139 if defined $optarg || defined $rest;
1140 return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1141
1142 # Check for option or option list terminator.
1143 if ($arg eq $argend ||
1144 $arg =~ /^$prefix.+/) {
1145 # Push back.
1146 unshift (@$argv, $arg);
1147 # Supply empty value.
1148 $arg = '';
1149 }
1150 }
1151
1152 elsif ( $type eq 'i' # numeric/integer
1153 || $type eq 'I' # numeric/integer w/ incr default
1154 || $type eq 'o' ) { # dec/oct/hex/bin value
1155
115611µs my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1157
1158167µs247µs if ( $bundling && defined $rest
# spent 43µs making 1 call to Getopt::Long::CORE:regcomp # spent 4µs making 1 call to Getopt::Long::CORE:match
1159 && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1160 ($key, $arg, $rest) = ($1, $2, $+);
1161 chop($key) if $key;
1162 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1163 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1164 }
1165 elsif ( $arg =~ /^$o_valid$/si ) {
116612µs $arg =~ tr/_//d;
116714µs $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1168 }
1169 else {
1170 if ( defined $optarg || $mand ) {
1171 if ( $passthrough ) {
1172 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1173 unless defined $optarg;
1174 return (0);
1175 }
1176 warn ("Value \"", $arg, "\" invalid for option ",
1177 $opt, " (",
1178 $type eq 'o' ? "extended " : '',
1179 "number expected)\n");
1180 $error++;
1181 # Push back.
1182 unshift (@$argv, $starter.$rest) if defined $rest;
1183 return (1, undef);
1184 }
1185 else {
1186 # Push back.
1187 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1188 if ( $type eq 'I' ) {
1189 # Fake incremental type.
1190 my @c = @$ctl;
1191 $c[CTL_TYPE] = '+';
1192 return (1, $opt, \@c, 1);
1193 }
1194 # Supply default value.
1195 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1196 }
1197 }
1198 }
1199
1200 elsif ( $type eq 'f' ) { # real number, int is also ok
1201 # We require at least one digit before a point or 'e',
1202 # and at least one digit following the point and 'e'.
1203 # [-]NN[.NN][eNN]
1204 my $o_valid = PAT_FLOAT;
1205 if ( $bundling && defined $rest &&
1206 $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1207 $arg =~ tr/_//d;
1208 ($key, $arg, $rest) = ($1, $2, $+);
1209 chop($key) if $key;
1210 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1211 }
1212 elsif ( $arg =~ /^$o_valid$/ ) {
1213 $arg =~ tr/_//d;
1214 }
1215 else {
1216 if ( defined $optarg || $mand ) {
1217 if ( $passthrough ) {
1218 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1219 unless defined $optarg;
1220 return (0);
1221 }
1222 warn ("Value \"", $arg, "\" invalid for option ",
1223 $opt, " (real number expected)\n");
1224 $error++;
1225 # Push back.
1226 unshift (@$argv, $starter.$rest) if defined $rest;
1227 return (1, undef);
1228 }
1229 else {
1230 # Push back.
1231 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1232 # Supply default value.
1233 $arg = 0.0;
1234 }
1235 }
1236 }
1237 else {
1238 die("Getopt::Long internal error (Can't happen)\n");
1239 }
124018µs return (1, $opt, $ctl, $arg, $key);
1241}
1242
1243sub ValidValue ($$$$$) {
1244 my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1245
1246 if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1247 return 0 unless $arg =~ /[^=]+=(.*)/;
1248 $arg = $1;
1249 }
1250
1251 my $type = $ctl->[CTL_TYPE];
1252
1253 if ( $type eq 's' ) { # string
1254 # A mandatory string takes anything.
1255 return (1) if $mand;
1256
1257 return (1) if $arg eq "-";
1258
1259 # Check for option or option list terminator.
1260 return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1261 return 1;
1262 }
1263
1264 elsif ( $type eq 'i' # numeric/integer
1265 || $type eq 'I' # numeric/integer w/ incr default
1266 || $type eq 'o' ) { # dec/oct/hex/bin value
1267
1268 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1269 return $arg =~ /^$o_valid$/si;
1270 }
1271
1272 elsif ( $type eq 'f' ) { # real number, int is also ok
1273 # We require at least one digit before a point or 'e',
1274 # and at least one digit following the point and 'e'.
1275 # [-]NN[.NN][eNN]
1276 my $o_valid = PAT_FLOAT;
1277 return $arg =~ /^$o_valid$/;
1278 }
1279 die("ValidValue: Cannot happen\n");
1280}
1281
1282# Getopt::Long Configuration.
1283
# spent 203µs (177+26) within Getopt::Long::Configure which was called 7 times, avg 29µs/call: # 2 times (59µs+12µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 427 of Getopt/Long/Descriptive.pm, avg 35µs/call # once (72µs+14µs) by Getopt::Long::Parser::new at line 150 # once (16µs+0s) by Getopt::Long::Parser::getoptionsfromarray at line 202 # once (14µs+0s) by Getopt::Long::Parser::new at line 151 # once (13µs+0s) by Getopt::Long::Parser::getoptionsfromarray at line 187 # once (4µs+0s) by Getopt::Long::Descriptive::BEGIN@8 at line 134
sub Configure (@) {
128477µs my (@options) = @_;
1285
1286720µs my $prevconfig =
1287 [ $error, $debug, $major_version, $minor_version,
1288 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1289 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1290 $longprefix ];
1291
1292710µs if ( ref($options[0]) eq 'ARRAY' ) {
1293 ( $error, $debug, $major_version, $minor_version,
1294 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1295 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1296420µs $longprefix ) = @{shift(@options)};
1297 }
1298
129972µs my $opt;
130078µs foreach $opt ( @options ) {
1301105µs my $try = lc ($opt);
1302102µs my $action = 1;
13031040µs1016µs if ( $try =~ /^no_?(.*)$/s ) {
# spent 16µs making 10 calls to Getopt::Long::CORE:match, avg 2µs/call
130461µs $action = 0;
130568µs $try = $+;
1306 }
13071060µs1810µs if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
# spent 10µs making 18 calls to Getopt::Long::CORE:match, avg 528ns/call
1308 ConfigDefaults ();
1309 }
1310 elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1311 local $ENV{POSIXLY_CORRECT};
1312 $ENV{POSIXLY_CORRECT} = 1 if $action;
1313 ConfigDefaults ();
1314 }
1315 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
13161500ns $autoabbrev = $action;
1317 }
1318 elsif ( $try eq 'getopt_compat' ) {
1319 $getopt_compat = $action;
1320 $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1321 }
1322 elsif ( $try eq 'gnu_getopt' ) {
1323 if ( $action ) {
1324 $gnu_compat = 1;
1325 $bundling = 1;
1326 $getopt_compat = 0;
1327 $genprefix = "(--|-)";
1328 $order = $PERMUTE;
1329 }
1330 }
1331 elsif ( $try eq 'gnu_compat' ) {
1332 $gnu_compat = $action;
1333 }
1334 elsif ( $try =~ /^(auto_?)?version$/ ) {
1335 $auto_version = $action;
1336 }
1337 elsif ( $try =~ /^(auto_?)?help$/ ) {
13382500ns $auto_help = $action;
1339 }
1340 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
13413700ns $ignorecase = $action;
1342 }
1343 elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1344 $ignorecase = $action ? 2 : 0;
1345 }
1346 elsif ( $try eq 'bundling' ) {
13472400ns $bundling = $action;
1348 }
1349 elsif ( $try eq 'bundling_override' ) {
1350 $bundling = $action ? 2 : 0;
1351 }
1352 elsif ( $try eq 'require_order' ) {
1353 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1354 }
1355 elsif ( $try eq 'permute' ) {
1356 $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1357 }
1358 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
13592900ns $passthrough = $action;
1360 }
1361 elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1362 $genprefix = $1;
1363 # Turn into regexp. Needs to be parenthesized!
1364 $genprefix = "(" . quotemeta($genprefix) . ")";
1365 eval { '' =~ /$genprefix/; };
1366 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1367 }
1368 elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1369 $genprefix = $1;
1370 # Parenthesize if needed.
1371 $genprefix = "(" . $genprefix . ")"
1372 unless $genprefix =~ /^\(.*\)$/;
1373 eval { '' =~ m"$genprefix"; };
1374 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1375 }
1376 elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1377 $longprefix = $1;
1378 # Parenthesize if needed.
1379 $longprefix = "(" . $longprefix . ")"
1380 unless $longprefix =~ /^\(.*\)$/;
1381 eval { '' =~ m"$longprefix"; };
1382 die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
1383 }
1384 elsif ( $try eq 'debug' ) {
1385 $debug = $action;
1386 }
1387 else {
1388 die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
1389 }
1390 }
1391738µs $prevconfig;
1392}
1393
1394# Deprecated name.
1395sub config (@) {
1396 Configure (@_);
1397}
1398
1399# Issue a standard message for --version.
1400#
1401# The arguments are mostly the same as for Pod::Usage::pod2usage:
1402#
1403# - a number (exit value)
1404# - a string (lead in message)
1405# - a hash with options. See Pod::Usage for details.
1406#
1407sub VersionMessage(@) {
1408 # Massage args.
1409 my $pa = setup_pa_args("version", @_);
1410
1411 my $v = $main::VERSION;
1412 my $fh = $pa->{-output} ||
1413 ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1414
1415 print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1416 $0, defined $v ? " version $v" : (),
1417 "\n",
1418 "(", __PACKAGE__, "::", "GetOptions",
1419 " version ",
1420 defined($Getopt::Long::VERSION_STRING)
1421 ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1422 " Perl version ",
1423 $] >= 5.006 ? sprintf("%vd", $^V) : $],
1424 ")\n");
1425 exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1426}
1427
1428# Issue a standard message for --help.
1429#
1430# The arguments are the same as for Pod::Usage::pod2usage:
1431#
1432# - a number (exit value)
1433# - a string (lead in message)
1434# - a hash with options. See Pod::Usage for details.
1435#
1436sub HelpMessage(@) {
1437 eval {
1438 require Pod::Usage;
1439 import Pod::Usage;
1440 1;
1441 } || die("Cannot provide help: cannot load Pod::Usage\n");
1442
1443 # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1444 pod2usage(setup_pa_args("help", @_));
1445
1446}
1447
1448# Helper routine to set up a normalized hash ref to be used as
1449# argument to pod2usage.
1450sub setup_pa_args($@) {
1451 my $tag = shift; # who's calling
1452
1453 # If called by direct binding to an option, it will get the option
1454 # name and value as arguments. Remove these, if so.
1455 @_ = () if @_ == 2 && $_[0] eq $tag;
1456
1457 my $pa;
1458 if ( @_ > 1 ) {
1459 $pa = { @_ };
1460 }
1461 else {
1462 $pa = shift || {};
1463 }
1464
1465 # At this point, $pa can be a number (exit value), string
1466 # (message) or hash with options.
1467
1468 if ( UNIVERSAL::isa($pa, 'HASH') ) {
1469 # Get rid of -msg vs. -message ambiguity.
1470 $pa->{-message} = $pa->{-msg};
1471 delete($pa->{-msg});
1472 }
1473 elsif ( $pa =~ /^-?\d+$/ ) {
1474 $pa = { -exitval => $pa };
1475 }
1476 else {
1477 $pa = { -message => $pa };
1478 }
1479
1480 # These are _our_ defaults.
1481 $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1482 $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1483 $pa;
1484}
1485
1486# Sneak way to know what version the user requested.
1487
# spent 19µs (9+10) within Getopt::Long::VERSION which was called: # once (9µs+10µs) by Getopt::Long::Descriptive::BEGIN@8 at line 8 of Getopt/Long/Descriptive.pm
sub VERSION {
14881300ns $requested_version = $_[1];
1489120µs110µs shift->SUPER::VERSION(@_);
# spent 10µs making 1 call to UNIVERSAL::VERSION
1490}
1491
1492package Getopt::Long::CallBack;
1493
1494sub new {
1495 my ($pkg, %atts) = @_;
1496 bless { %atts }, $pkg;
1497}
1498
1499sub name {
1500 my $self = shift;
1501 ''.$self->{name};
1502}
1503
1504use overload
1505 # Treat this object as an ordinary string for legacy API.
150617µs134µs
# spent 45µs (11+34) within Getopt::Long::CallBack::BEGIN@1506 which was called: # once (11µs+34µs) by Getopt::Long::Descriptive::BEGIN@8 at line 1507
'""' => \&name,
# spent 34µs making 1 call to overload::import
1507131µs145µs fallback => 1;
# spent 45µs making 1 call to Getopt::Long::CallBack::BEGIN@1506
1508
150917µs1;
1510
1511################ Documentation ################
1512
 
# spent 272µs within Getopt::Long::CORE:match which was called 120 times, avg 2µs/call: # 24 times (98µs+0s) by Getopt::Long::ParseOptionSpec at line 787, avg 4µs/call # 24 times (49µs+0s) by Getopt::Long::GetOptionsFromArray at line 350, avg 2µs/call # 18 times (10µs+0s) by Getopt::Long::Configure at line 1307, avg 528ns/call # 16 times (61µs+0s) by Getopt::Long::ParseOptionSpec at line 849, avg 4µs/call # 16 times (10µs+0s) by Getopt::Long::ParseOptionSpec at line 833, avg 600ns/call # 10 times (16µs+0s) by Getopt::Long::Configure at line 1303, avg 2µs/call # 4 times (9µs+0s) by Getopt::Long::FindOption at line 918, avg 2µs/call # 3 times (7µs+0s) by Getopt::Long::GetOptionsFromArray at line 328, avg 2µs/call # 3 times (500ns+0s) by Getopt::Long::FindOption at line 931, avg 167ns/call # once (8µs+0s) by Getopt::Long::Descriptive::BEGIN@8 at line 124 # once (4µs+0s) by Getopt::Long::FindOption at line 1158
sub Getopt::Long::CORE:match; # opcode
# spent 126µs within Getopt::Long::CORE:regcomp which was called 32 times, avg 4µs/call: # 24 times (62µs+0s) by Getopt::Long::GetOptionsFromArray at line 350, avg 3µs/call # 4 times (13µs+0s) by Getopt::Long::FindOption at line 918, avg 3µs/call # 3 times (8µs+0s) by Getopt::Long::FindOption at line 931, avg 3µs/call # once (43µs+0s) by Getopt::Long::FindOption at line 1158
sub Getopt::Long::CORE:regcomp; # opcode