← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ./testnewboardincnply
  Run on Mon Jan 12 21:52:27 2015
Reported on Mon Jan 12 22:01:18 2015

Filename/usr/share/perl/5.14/Getopt/Long.pm
StatementsExecuted 285 statements in 6.30ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111731µs930µsGetopt::Long::::BEGIN@208 Getopt::Long::BEGIN@208
111301µs388µsGetopt::Long::::BEGIN@19 Getopt::Long::BEGIN@19
11160µs208µsGetopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
21148µs78µsGetopt::Long::::FindOption Getopt::Long::FindOption
21145µs54µsGetopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
85135µs35µsGetopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
1710130µs30µsGetopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
11113µs13µsGetopt::Long::::BEGIN@15 Getopt::Long::BEGIN@15
11112µs1.19msGetopt::Long::::import Getopt::Long::import
1117µs33µsGetopt::Long::CallBack::::BEGIN@1489Getopt::Long::CallBack::BEGIN@1489
1116µs19µsGetopt::Long::::BEGIN@25 Getopt::Long::BEGIN@25
1115µs7µsGetopt::Long::::BEGIN@17 Getopt::Long::BEGIN@17
1115µs24µsGetopt::Long::::BEGIN@218 Getopt::Long::BEGIN@218
1114µs4µsGetopt::Long::::GetOptions Getopt::Long::GetOptions
1114µs76µsGetopt::Long::::BEGIN@45 Getopt::Long::BEGIN@45
1114µs36µsGetopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1114µs21µsGetopt::Long::::BEGIN@226 Getopt::Long::BEGIN@226
1114µs22µsGetopt::Long::::BEGIN@220 Getopt::Long::BEGIN@220
1114µs4µsGetopt::Long::::BEGIN@37 Getopt::Long::BEGIN@37
1114µs21µsGetopt::Long::::BEGIN@223 Getopt::Long::BEGIN@223
1114µs26µsGetopt::Long::::BEGIN@247 Getopt::Long::BEGIN@247
1114µs30µsGetopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1114µs20µsGetopt::Long::::BEGIN@225 Getopt::Long::BEGIN@225
1114µs48µsGetopt::Long::::BEGIN@51 Getopt::Long::BEGIN@51
1114µs21µsGetopt::Long::::BEGIN@237 Getopt::Long::BEGIN@237
1114µs21µsGetopt::Long::::BEGIN@224 Getopt::Long::BEGIN@224
1114µs21µsGetopt::Long::::BEGIN@222 Getopt::Long::BEGIN@222
1114µs20µsGetopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1114µs21µsGetopt::Long::::BEGIN@229 Getopt::Long::BEGIN@229
1114µs45µsGetopt::Long::::BEGIN@48 Getopt::Long::BEGIN@48
1114µs21µsGetopt::Long::::BEGIN@228 Getopt::Long::BEGIN@228
1113µs3µsGetopt::Long::::Configure Getopt::Long::Configure
1113µs3µsGetopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
1112µs2µsGetopt::Long::::CORE:sort Getopt::Long::CORE:sort (opcode)
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::::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# Getopt::Long.pm -- Universal options parsing
2
3package Getopt::Long;
4
5# RCS Status : $Id: Long.pm,v 2.76 2009/03/30 20:54:30 jv Exp $
6# Author : Johan Vromans
7# Created On : Tue Sep 11 15:00:12 1990
8# Last Modified By: Johan Vromans
9# Last Modified On: Mon Mar 30 22:51:17 2009
10# Update Count : 1601
11# Status : Released
12
13################ Module Preamble ################
14
15234µs113µs
# spent 13µs within Getopt::Long::BEGIN@15 which was called: # once (13µs+0s) by main::BEGIN@10 at line 15
use 5.004;
# spent 13µs making 1 call to Getopt::Long::BEGIN@15
16
17221µs210µs
# spent 7µs (5+2) within Getopt::Long::BEGIN@17 which was called: # once (5µs+2µs) by main::BEGIN@10 at line 17
use strict;
# spent 7µs making 1 call to Getopt::Long::BEGIN@17 # spent 2µs making 1 call to strict::import
18
19274µs2405µs
# spent 388µs (301+88) within Getopt::Long::BEGIN@19 which was called: # once (301µs+88µs) by main::BEGIN@10 at line 19
use vars qw($VERSION);
# spent 388µs making 1 call to Getopt::Long::BEGIN@19 # spent 16µs making 1 call to vars::import
201400ns$VERSION = 2.38;
21# For testing versions only.
22#use vars qw($VERSION_STRING);
23#$VERSION_STRING = "2.38";
24
25220µs232µs
# spent 19µs (6+13) within Getopt::Long::BEGIN@25 which was called: # once (6µs+13µs) by main::BEGIN@10 at line 25
use Exporter;
# spent 19µs making 1 call to Getopt::Long::BEGIN@25 # spent 13µs making 1 call to Exporter::import
26256µs256µs
# spent 30µs (4+26) within Getopt::Long::BEGIN@26 which was called: # once (4µs+26µs) by main::BEGIN@10 at line 26
use vars qw(@ISA @EXPORT @EXPORT_OK);
# spent 30µs making 1 call to Getopt::Long::BEGIN@26 # spent 26µs making 1 call to vars::import
2714µ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 main::BEGIN@10 at line 42
BEGIN {
38 # Init immediately so their contents can be used in the 'use vars' below.
3924µs @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
40 @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
41 &GetOptionsFromArray &GetOptionsFromString);
42117µs14µs}
# spent 4µs making 1 call to Getopt::Long::BEGIN@37
43
44# User visible variables.
45221µs2147µs
# spent 76µs (4+71) within Getopt::Long::BEGIN@45 which was called: # once (4µs+71µs) by main::BEGIN@10 at line 45
use vars @EXPORT, @EXPORT_OK;
# spent 76µs making 1 call to Getopt::Long::BEGIN@45 # spent 71µs making 1 call to vars::import
46220µs268µs
# spent 36µs (4+32) within Getopt::Long::BEGIN@46 which was called: # once (4µs+32µs) by main::BEGIN@10 at line 46
use vars qw($error $debug $major_version $minor_version);
# spent 36µs making 1 call to Getopt::Long::BEGIN@46 # spent 32µs making 1 call to vars::import
47# Deprecated visible variables.
48142µs
# spent 45µs (4+42) within Getopt::Long::BEGIN@48 which was called: # once (4µs+42µs) by main::BEGIN@10 at line 49
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
# spent 42µs making 1 call to vars::import
49219µs145µs $passthrough);
# spent 45µs making 1 call to Getopt::Long::BEGIN@48
50# Official invisible variables.
512466µs292µs
# spent 48µs (4+44) within Getopt::Long::BEGIN@51 which was called: # once (4µs+44µs) by main::BEGIN@10 at line 51
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# spent 48µs making 1 call to Getopt::Long::BEGIN@51 # spent 44µ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 3µs within Getopt::Long::ConfigDefaults which was called: # once (3µs+0s) by main::BEGIN@10 at line 125
sub ConfigDefaults() {
73 # Handle POSIX compliancy.
74124µ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 {
82 $genprefix = "(--|-|\\+)";
83 $autoabbrev = 1; # automatic abbrev of options
84 $bundling = 0; # bundling off by default
85 $getopt_compat = 1; # allow '+' to start options
86 $order = $PERMUTE;
87 }
88 # Other configurable settings.
89 $debug = 0; # for debugging
90 $error = 0; # error tally
91 $ignorecase = 1; # ignore case when matching options
92 $passthrough = 0; # leave unrecognized options alone
93 $gnu_compat = 0; # require --opt=val if value is optional
94 $longprefix = "(--)"; # what does a long prefix look like
95}
96
97# Override import.
98
# spent 1.19ms (12µs+1.17) within Getopt::Long::import which was called: # once (12µs+1.17ms) by main::BEGIN@10 at line 10 of testnewboardincnply
sub import {
99912µs my $pkg = shift; # package
100 my @syms = (); # symbols to import
101 my @config = (); # configuration
102 my $dest = \@syms; # symbols first
103 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.
111 local $Exporter::ExportLevel = 1;
112 push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
11311.17ms $pkg->SUPER::import(@syms);
# spent 1.17ms making 1 call to Exporter::import
114 # And configure.
115 Configure(@config) if @config;
116}
117
118################ Initialization ################
119
120# Values for $order. See GNU getopt.c for details.
1211600ns($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
122# Version major/minor numbers.
123116µs112µs($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
# spent 12µs making 1 call to Getopt::Long::CORE:match
124
12511µs13µsConfigDefaults();
# spent 3µs making 1 call to Getopt::Long::ConfigDefaults
126
127################ OO Interface ################
128
129package Getopt::Long::Parser;
130
131# Store a copy of the default configuration. Since ConfigDefaults has
132# just been called, what we get from Configure is the default.
1331800ns13µsmy $default_config = do {
# spent 3µs making 1 call to Getopt::Long::Configure
134 Getopt::Long::Configure ()
135};
136
137sub new {
138 my $that = shift;
139 my $class = ref($that) || $that;
140 my %atts = @_;
141
142 # Register the callers package.
143 my $self = { caller_pkg => (caller)[0] };
144
145 bless ($self, $class);
146
147 # Process config attributes.
148 if ( defined $atts{config} ) {
149 my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
150 $self->{settings} = Getopt::Long::Configure ($save);
151 delete ($atts{config});
152 }
153 # Else use default config.
154 else {
155 $self->{settings} = $default_config;
156 }
157
158 if ( %atts ) { # Oops
159 die(__PACKAGE__.": unhandled attributes: ".
160 join(" ", sort(keys(%atts)))."\n");
161 }
162
163 $self;
164}
165
166sub configure {
167 my ($self) = shift;
168
169 # Restore settings, merge new settings in.
170 my $save = Getopt::Long::Configure ($self->{settings}, @_);
171
172 # Restore orig config and save the new config.
173 $self->{settings} = Getopt::Long::Configure ($save);
174}
175
176sub getoptions {
177 my ($self) = shift;
178
179 # Restore config settings.
180 my $save = Getopt::Long::Configure ($self->{settings});
181
182 # Call main routine.
183 my $ret = 0;
184 $Getopt::Long::caller = $self->{caller_pkg};
185
186 eval {
187 # Locally set exception handler to default, otherwise it will
188 # be called implicitly here, and again explicitly when we try
189 # to deliver the messages.
190 local ($SIG{__DIE__}) = 'DEFAULT';
191 $ret = Getopt::Long::GetOptions (@_);
192 };
193
194 # Restore saved settings.
195 Getopt::Long::Configure ($save);
196
197 # Handle errors and return value.
198 die ($@) if $@;
199 return $ret;
200}
201
202package Getopt::Long;
203
204################ Back to Normal ################
205
206# Indices in option control info.
207# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
208284µs2961µs
# spent 930µs (731+200) within Getopt::Long::BEGIN@208 which was called: # once (731µs+200µs) by main::BEGIN@10 at line 208
use constant CTL_TYPE => 0;
# spent 930µs making 1 call to Getopt::Long::BEGIN@208 # spent 31µs making 1 call to constant::import
209#use constant CTL_TYPE_FLAG => '';
210#use constant CTL_TYPE_NEG => '!';
211#use constant CTL_TYPE_INCR => '+';
212#use constant CTL_TYPE_INT => 'i';
213#use constant CTL_TYPE_INTINC => 'I';
214#use constant CTL_TYPE_XINT => 'o';
215#use constant CTL_TYPE_FLOAT => 'f';
216#use constant CTL_TYPE_STRING => 's';
217
218219µs243µs
# spent 24µs (5+19) within Getopt::Long::BEGIN@218 which was called: # once (5µs+19µs) by main::BEGIN@10 at line 218
use constant CTL_CNAME => 1;
# spent 24µs making 1 call to Getopt::Long::BEGIN@218 # spent 19µs making 1 call to constant::import
219
220218µs240µs
# spent 22µs (4+18) within Getopt::Long::BEGIN@220 which was called: # once (4µs+18µs) by main::BEGIN@10 at line 220
use constant CTL_DEFAULT => 2;
# spent 22µs making 1 call to Getopt::Long::BEGIN@220 # spent 18µs making 1 call to constant::import
221
222217µs238µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@222 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 222
use constant CTL_DEST => 3;
# spent 21µs making 1 call to Getopt::Long::BEGIN@222 # spent 17µs making 1 call to constant::import
223220µs238µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@223 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 223
use constant CTL_DEST_SCALAR => 0;
# spent 21µs making 1 call to Getopt::Long::BEGIN@223 # spent 17µs making 1 call to constant::import
224217µs239µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@224 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 224
use constant CTL_DEST_ARRAY => 1;
# spent 21µs making 1 call to Getopt::Long::BEGIN@224 # spent 17µs making 1 call to constant::import
225216µs237µs
# spent 20µs (4+17) within Getopt::Long::BEGIN@225 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 225
use constant CTL_DEST_HASH => 2;
# spent 20µs making 1 call to Getopt::Long::BEGIN@225 # spent 17µs making 1 call to constant::import
226217µs239µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@226 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 226
use constant CTL_DEST_CODE => 3;
# spent 21µs making 1 call to Getopt::Long::BEGIN@226 # spent 17µs making 1 call to constant::import
227
228217µs238µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@228 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 228
use constant CTL_AMIN => 4;
# spent 21µs making 1 call to Getopt::Long::BEGIN@228 # spent 17µs making 1 call to constant::import
229219µs238µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@229 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 229
use constant CTL_AMAX => 5;
# spent 21µs making 1 call to Getopt::Long::BEGIN@229 # spent 17µs making 1 call to constant::import
230
231# FFU.
232#use constant CTL_RANGE => ;
233#use constant CTL_REPEAT => ;
234
235# Rather liberal patterns to match numbers.
236230µs237µs
# spent 20µs (4+17) within Getopt::Long::BEGIN@236 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 236
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
# spent 20µs making 1 call to Getopt::Long::BEGIN@236 # spent 17µs making 1 call to constant::import
237117µs
# spent 21µs (4+17) within Getopt::Long::BEGIN@237 which was called: # once (4µs+17µs) by main::BEGIN@10 at line 246
use constant PAT_XINT =>
# spent 17µs making 1 call to constant::import
238 "(?:".
239 "[-+]?_*[1-9][0-9_]*".
240 "|".
241 "0x_*[0-9a-f][0-9a-f_]*".
242 "|".
243 "0b_*[01][01_]*".
244 "|".
245 "0[0-7_]*".
246220µs121µs ")";
# spent 21µs making 1 call to Getopt::Long::BEGIN@237
24724.94ms249µs
# spent 26µs (4+22) within Getopt::Long::BEGIN@247 which was called: # once (4µs+22µs) by main::BEGIN@10 at line 247
use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
# spent 26µs making 1 call to Getopt::Long::BEGIN@247 # spent 22µs making 1 call to constant::import
248
249
# spent 4µs within Getopt::Long::GetOptions which was called: # once (4µs+0s) by main::RUNTIME at line 20 of testnewboardincnply
sub GetOptions(@) {
250 # Shift in default array.
25126µs unshift(@_, \@ARGV);
252 # Try to keep caller() and Carp consitent.
2531208µs goto &GetOptionsFromArray;
# spent 208µs making 1 call to Getopt::Long::GetOptionsFromArray
254}
255
256sub GetOptionsFromString(@) {
257 my ($string) = shift;
258 require Text::ParseWords;
259 my $args = [ Text::ParseWords::shellwords($string) ];
260 $caller ||= (caller)[0]; # current context
261 my $ret = GetOptionsFromArray($args, @_);
262 return ( $ret, $args ) if wantarray;
263 if ( @$args ) {
264 $ret = 0;
265 warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
266 }
267 $ret;
268}
269
270
# spent 208µs (60+148) within Getopt::Long::GetOptionsFromArray which was called: # once (60µs+148µs) by main::RUNTIME at line 253
sub GetOptionsFromArray(@) {
271
2722518µs my ($argv, @optionlist) = @_; # local copy of the option descriptions
273 my $argend = '--'; # option list terminator
274 my %opctl = (); # table of option specs
275 my $pkg = $caller || (caller)[0]; # current context
276 # Needed if linkage is omitted.
277 my @ret = (); # accum for non-options
278 my %linkage; # linkage
279 my $userlinkage; # user supplied HASH
280 my $opt; # current option
281 my $prefix = $genprefix; # current prefix
282
283 $error = '';
284
285 if ( $debug ) {
286 # Avoid some warnings if debugging.
287 local ($^W) = 0;
288 print STDERR
289 ("Getopt::Long $Getopt::Long::VERSION (",
290 '$Revision: 2.76 $', ") ",
291 "called from package \"$pkg\".",
292 "\n ",
293 "argv: (@$argv)",
294 "\n ",
295 "autoabbrev=$autoabbrev,".
296 "bundling=$bundling,",
297 "getopt_compat=$getopt_compat,",
298 "gnu_compat=$gnu_compat,",
299 "order=$order,",
300 "\n ",
301 "ignorecase=$ignorecase,",
302 "requested_version=$requested_version,",
303 "passthrough=$passthrough,",
304 "genprefix=\"$genprefix\",",
305 "longprefix=\"$longprefix\".",
306 "\n");
307 }
308
309 # Check for ref HASH as first argument.
310 # First argument may be an object. It's OK to use this as long
311 # as it is really a hash underneath.
312 $userlinkage = undef;
313 if ( @optionlist && ref($optionlist[0]) and
314 UNIVERSAL::isa($optionlist[0],'HASH') ) {
315 $userlinkage = shift (@optionlist);
316 print STDERR ("=> user linkage: $userlinkage\n") if $debug;
317 }
318
319 # See if the first element of the optionlist contains option
320 # starter characters.
321 # Be careful not to interpret '<>' as option starters.
32212µs if ( @optionlist && $optionlist[0] =~ /^\W+$/
# spent 2µs making 1 call to Getopt::Long::CORE:match
323 && !($optionlist[0] eq '<>'
324 && @optionlist > 0
325 && ref($optionlist[1])) ) {
326 $prefix = shift (@optionlist);
327 # Turn into regexp. Needs to be parenthesized!
328 $prefix =~ s/(\W)/\\$1/g;
329 $prefix = "([" . $prefix . "])";
330 print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
331 }
332
333 # Verify correctness of optionlist.
334 %opctl = ();
335 while ( @optionlist ) {
3361837µs my $opt = shift (@optionlist);
337
338 unless ( defined($opt) ) {
339 $error .= "Undefined argument in option spec\n";
340 next;
341 }
342
343 # Strip leading prefix so people can specify "--foo=i" if they like.
344414µs $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
# spent 12µs making 2 calls to Getopt::Long::CORE:regcomp, avg 6µs/call # spent 2µs making 2 calls to Getopt::Long::CORE:match, avg 1µs/call
345
346 if ( $opt eq '<>' ) {
347 if ( (defined $userlinkage)
348 && !(@optionlist > 0 && ref($optionlist[0]))
349 && (exists $userlinkage->{$opt})
350 && ref($userlinkage->{$opt}) ) {
351 unshift (@optionlist, $userlinkage->{$opt});
352 }
353 unless ( @optionlist > 0
354 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
355 $error .= "Option spec <> requires a reference to a subroutine\n";
356 # Kill the linkage (to avoid another error).
357 shift (@optionlist)
358 if @optionlist && ref($optionlist[0]);
359 next;
360 }
361 $linkage{'<>'} = shift (@optionlist);
362 next;
363 }
364
365 # Parse option spec.
366254µs my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
# spent 54µs making 2 calls to Getopt::Long::ParseOptionSpec, avg 27µs/call
367 unless ( defined $name ) {
368 # Failed. $orig contains the error message. Sorry for the abuse.
369 $error .= $orig;
370 # Kill the linkage (to avoid another error).
371 shift (@optionlist)
372 if @optionlist && ref($optionlist[0]);
373 next;
374 }
375
376 # If no linkage is supplied in the @optionlist, copy it from
377 # the userlinkage if available.
378 if ( defined $userlinkage ) {
379 unless ( @optionlist > 0 && ref($optionlist[0]) ) {
380 if ( exists $userlinkage->{$orig} &&
381 ref($userlinkage->{$orig}) ) {
382 print STDERR ("=> found userlinkage for \"$orig\": ",
383 "$userlinkage->{$orig}\n")
384 if $debug;
385 unshift (@optionlist, $userlinkage->{$orig});
386 }
387 else {
388 # Do nothing. Being undefined will be handled later.
389 next;
390 }
391 }
392 }
393
394 # Copy the linkage. If omitted, link to global variable.
39563µs if ( @optionlist > 0 && ref($optionlist[0]) ) {
396 print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
397 if $debug;
398 my $rl = ref($linkage{$orig} = shift (@optionlist));
399
400 if ( $rl eq "ARRAY" ) {
401 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
402 }
403 elsif ( $rl eq "HASH" ) {
404 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
405 }
406 elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
407# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
408# my $t = $linkage{$orig};
409# $$t = $linkage{$orig} = [];
410# }
411# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
412# }
413# else {
414 # Ok.
415# }
416 }
417 elsif ( $rl eq "CODE" ) {
418 # Ok.
419 }
420 else {
421 $error .= "Invalid option linkage for \"$opt\"\n";
422 }
423 }
424 else {
425 # Link to global $opt_XXX variable.
426 # Make sure a valid perl identifier results.
427 my $ov = $orig;
428 $ov =~ s/\W/_/g;
429 if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
430 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
431 if $debug;
432 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
433 }
434 elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
435 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
436 if $debug;
437 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
438 }
439 else {
440 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
441 if $debug;
442 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
443 }
444 }
445
446 if ( $opctl{$name}[CTL_TYPE] eq 'I'
447 && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
448 || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
449 ) {
450 $error .= "Invalid option linkage for \"$opt\"\n";
451 }
452
453 }
454
455 # Bail out if errors found.
456 die ($error) if $error;
457 $error = 0;
458
459 # Supply --version and --help support, if needed and allowed.
460 if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
461 if ( !defined($opctl{version}) ) {
462 $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
463 $linkage{version} = \&VersionMessage;
464 }
465 $auto_version = 1;
466 }
467 if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
468 if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
469 $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
470 $linkage{help} = \&HelpMessage;
471 }
472 $auto_help = 1;
473 }
474
475 # Show the options tables if debugging.
476 if ( $debug ) {
477 my ($arrow, $k, $v);
478 $arrow = "=> ";
479 while ( ($k,$v) = each(%opctl) ) {
480 print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
481 $arrow = " ";
482 }
483 }
484
485 # Process argument list
486 my $goon = 1;
487 while ( $goon && @$argv > 0 ) {
488
489 # Get next argument.
490208µs $opt = shift (@$argv);
491 print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
492
493 # Double dash is option list terminator.
494 if ( $opt eq $argend ) {
495 push (@ret, $argend) if $passthrough;
496 last;
497 }
498
499 # Look it up.
500 my $tryopt = $opt;
501 my $found; # success status
502 my $key; # key (if hash type)
503 my $arg; # option argument
504 my $ctl; # the opctl entry
505
506278µs ($found, $opt, $ctl, $arg, $key) =
# spent 78µs making 2 calls to Getopt::Long::FindOption, avg 39µs/call
507 FindOption ($argv, $prefix, $argend, $opt, \%opctl);
508
50962µs if ( $found ) {
510
511 # FindOption undefines $opt in case of errors.
512 next unless defined $opt;
513
514 my $argcnt = 0;
515 while ( defined $arg ) {
516
517 # Get the canonical name.
51863µs print STDERR ("=> cname for \"$opt\" is ") if $debug;
519 $opt = $ctl->[CTL_CNAME];
520 print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
521
52221µs if ( defined $linkage{$opt} ) {
523 print STDERR ("=> ref(\$L{$opt}) -> ",
524 ref($linkage{$opt}), "\n") if $debug;
525
5261900ns if ( ref($linkage{$opt}) eq 'SCALAR'
527 || ref($linkage{$opt}) eq 'REF' ) {
5282500ns if ( $ctl->[CTL_TYPE] eq '+' ) {
529 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
530 if $debug;
531 if ( defined ${$linkage{$opt}} ) {
532 ${$linkage{$opt}} += $arg;
533 }
534 else {
535 ${$linkage{$opt}} = $arg;
536 }
537 }
538 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
539 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
540 " to ARRAY\n")
541 if $debug;
542 my $t = $linkage{$opt};
543 $$t = $linkage{$opt} = [];
544 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
545 if $debug;
546 push (@{$linkage{$opt}}, $arg);
547 }
548 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
549 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
550 " to HASH\n")
551 if $debug;
552 my $t = $linkage{$opt};
553 $$t = $linkage{$opt} = {};
554 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
555 if $debug;
556 $linkage{$opt}->{$key} = $arg;
557 }
558 else {
559 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
560 if $debug;
561 ${$linkage{$opt}} = $arg;
562 }
563 }
564 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
565 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
566 if $debug;
567 push (@{$linkage{$opt}}, $arg);
568 }
569 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
570 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
571 if $debug;
572 $linkage{$opt}->{$key} = $arg;
573 }
574 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
575 print STDERR ("=> &L{$opt}(\"$opt\"",
576 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
577 ", \"$arg\")\n")
578 if $debug;
579 my $eval_error = do {
580 local $@;
581 local $SIG{__DIE__} = 'DEFAULT';
582 eval {
583 &{$linkage{$opt}}
584 (Getopt::Long::CallBack->new
585 (name => $opt,
586 ctl => $ctl,
587 opctl => \%opctl,
588 linkage => \%linkage,
589 prefix => $prefix,
590 ),
591 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
592 $arg);
593 };
594 $@;
595 };
596 print STDERR ("=> die($eval_error)\n")
597 if $debug && $eval_error ne '';
598 if ( $eval_error =~ /^!/ ) {
599 if ( $eval_error =~ /^!FINISH\b/ ) {
600 $goon = 0;
601 }
602 }
603 elsif ( $eval_error ne '' ) {
604 warn ($eval_error);
605 $error++;
606 }
607 }
608 else {
609 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
610 "\" in linkage\n");
611 die("Getopt::Long -- internal error!\n");
612 }
613 }
614 # No entry in linkage means entry in userlinkage.
615 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
616 if ( defined $userlinkage->{$opt} ) {
617 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
618 if $debug;
619 push (@{$userlinkage->{$opt}}, $arg);
620 }
621 else {
622 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
623 if $debug;
624 $userlinkage->{$opt} = [$arg];
625 }
626 }
627 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
628 if ( defined $userlinkage->{$opt} ) {
629 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
630 if $debug;
631 $userlinkage->{$opt}->{$key} = $arg;
632 }
633 else {
634 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
635 if $debug;
636 $userlinkage->{$opt} = {$key => $arg};
637 }
638 }
639 else {
640 if ( $ctl->[CTL_TYPE] eq '+' ) {
641 print STDERR ("=> \$L{$opt} += \"$arg\"\n")
642 if $debug;
643 if ( defined $userlinkage->{$opt} ) {
644 $userlinkage->{$opt} += $arg;
645 }
646 else {
647 $userlinkage->{$opt} = $arg;
648 }
649 }
650 else {
651 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
652 $userlinkage->{$opt} = $arg;
653 }
654 }
655
656 $argcnt++;
657 last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
658 undef($arg);
659
660 # Need more args?
661 if ( $argcnt < $ctl->[CTL_AMIN] ) {
662 if ( @$argv ) {
663 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
664 $arg = shift(@$argv);
665 $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
666 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
667 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
668 next;
669 }
670 warn("Value \"$$argv[0]\" invalid for option $opt\n");
671 $error++;
672 }
673 else {
674 warn("Insufficient arguments for option $opt\n");
675 $error++;
676 }
677 }
678
679 # Any more args?
680 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
681 $arg = shift(@$argv);
682 $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
683 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
684 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
685 next;
686 }
687 }
688 }
689
690 # Not an option. Save it if we $PERMUTE and don't have a <>.
691 elsif ( $order == $PERMUTE ) {
692 # Try non-options call-back.
693 my $cb;
6942800ns if ( (defined ($cb = $linkage{'<>'})) ) {
695 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
696 if $debug;
697 my $eval_error = do {
698 local $@;
699 local $SIG{__DIE__} = 'DEFAULT';
700 eval {
701 &$cb
702 (Getopt::Long::CallBack->new
703 (name => $tryopt,
704 ctl => $ctl,
705 opctl => \%opctl,
706 linkage => \%linkage,
707 prefix => $prefix,
708 ));
709 };
710 $@;
711 };
712 print STDERR ("=> die($eval_error)\n")
713 if $debug && $eval_error ne '';
714 if ( $eval_error =~ /^!/ ) {
715 if ( $eval_error =~ /^!FINISH\b/ ) {
716 $goon = 0;
717 }
718 }
719 elsif ( $eval_error ne '' ) {
720 warn ($eval_error);
721 $error++;
722 }
723 }
724 else {
725 print STDERR ("=> saving \"$tryopt\" ",
726 "(not an option, may permute)\n") if $debug;
727 push (@ret, $tryopt);
728 }
729 next;
730 }
731
732 # ...otherwise, terminate.
733 else {
734 # Push this one back and exit.
735 unshift (@$argv, $tryopt);
736 return ($error == 0);
737 }
738
739 }
740
741 # Finish.
7422600ns if ( @ret && $order == $PERMUTE ) {
743 # Push back accumulated arguments
744 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
745 if $debug;
746 unshift (@$argv, @ret);
747 }
748
749 return ($error == 0);
750}
751
752# A readable representation of what's in an optbl.
753sub OptCtl ($) {
754 my ($v) = @_;
755 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
756 "[".
757 join(",",
758 "\"$v[CTL_TYPE]\"",
759 "\"$v[CTL_CNAME]\"",
760 "\"$v[CTL_DEFAULT]\"",
761 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
762 $v[CTL_AMIN] || '',
763 $v[CTL_AMAX] || '',
764# $v[CTL_RANGE] || '',
765# $v[CTL_REPEAT] || '',
766 ). "]";
767}
768
769# Parse an option specification and fill the tables.
770
# spent 54µs (45+9) within Getopt::Long::ParseOptionSpec which was called 2 times, avg 27µs/call: # 2 times (45µs+9µs) by Getopt::Long::GetOptionsFromArray at line 366, avg 27µs/call
sub ParseOptionSpec ($$) {
7712624µs my ($opt, $opctl) = @_;
772
773 # Match option spec.
77424µs if ( $opt !~ m;^
# spent 4µs making 2 calls to Getopt::Long::CORE:match, avg 2µs/call
775 (
776 # Option name
777 (?: \w+[-\w]* )
778 # Alias names, or "?"
779 (?: \| (?: \? | \w[-\w]* ) )*
780 )?
781 (
782 # Either modifiers ...
783 [!+]
784 |
785 # ... or a value/dest/repeat specification
786 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
787 |
788 # ... or an optional-with-default spec
789 : (?: -?\d+ | \+ ) [@%]?
790 )?
791 $;x ) {
792 return (undef, "Error in option spec: \"$opt\"\n");
793 }
794
795 my ($names, $spec) = ($1, $2);
796 $spec = '' unless defined $spec;
797
798 # $orig keeps track of the primary name the user specified.
799 # This name will be used for the internal or external linkage.
800 # In other words, if the user specifies "FoO|BaR", it will
801 # match any case combinations of 'foo' and 'bar', but if a global
802 # variable needs to be set, it will be $opt_FoO in the exact case
803 # as specified.
804 my $orig;
805
806 my @names;
80743µs if ( defined $names ) {
808 @names = split (/\|/, $names);
809 $orig = $names[0];
810 }
811 else {
812 @names = ('');
813 $orig = '';
814 }
815
816 # Construct the opctl entries.
817 my $entry;
8182624µs21µs if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# spent 1µs making 2 calls to Getopt::Long::CORE:match, avg 500ns/call
819 # Fields are hard-wired here.
820 $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
821 }
822 elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
823 my $def = $1;
824 my $dest = $2;
825 my $type = $def eq '+' ? 'I' : 'i';
826 $dest ||= '$';
827 $dest = $dest eq '@' ? CTL_DEST_ARRAY
828 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
829 # Fields are hard-wired here.
830 $entry = [$type,$orig,$def eq '+' ? undef : $def,
831 $dest,0,1];
832 }
833 else {
83424µs my ($mand, $type, $dest) =
# spent 4µs making 2 calls to Getopt::Long::CORE:match, avg 2µs/call
835 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
836 return (undef, "Cannot repeat while bundling: \"$opt\"\n")
837 if $bundling && defined($4);
838 my ($mi, $cm, $ma) = ($5, $6, $7);
839 return (undef, "{0} is useless in option spec: \"$opt\"\n")
840 if defined($mi) && !$mi && !defined($ma) && !defined($cm);
841
842 $type = 'i' if $type eq 'n';
843 $dest ||= '$';
844 $dest = $dest eq '@' ? CTL_DEST_ARRAY
845 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
846 # Default minargs to 1/0 depending on mand status.
847 $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
848 # Adjust mand status according to minargs.
849 $mand = $mi ? '=' : ':';
850 # Adjust maxargs.
851 $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
852 return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
853 if defined($ma) && !$ma;
854 return (undef, "Max less than min in option spec: \"$opt\"\n")
855 if defined($ma) && $ma < $mi;
856
857 # Fields are hard-wired here.
858 $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
859 }
860
861 # Process all names. First is canonical, the rest are aliases.
862 my $dups = '';
863 foreach ( @names ) {
864
86563µs $_ = lc ($_)
866 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
867
868 if ( exists $opctl->{$_} ) {
869 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
870 }
871
87221µs if ( $spec eq '!' ) {
873 $opctl->{"no$_"} = $entry;
874 $opctl->{"no-$_"} = $entry;
875 $opctl->{$_} = [@$entry];
876 $opctl->{$_}->[CTL_TYPE] = '';
877 }
878 else {
879 $opctl->{$_} = $entry;
880 }
881 }
882
883 if ( $dups && $^W ) {
884 foreach ( split(/\n+/, $dups) ) {
885 warn($_."\n");
886 }
887 }
888 ($names[0], $orig);
889}
890
891# Option lookup.
892
# spent 78µs (48+29) within Getopt::Long::FindOption which was called 2 times, avg 39µs/call: # 2 times (48µs+29µs) by Getopt::Long::GetOptionsFromArray at line 506, avg 39µs/call
sub FindOption ($$$$$) {
893
894 # returns (1, $opt, $ctl, $arg, $key) if okay,
895 # returns (1, undef) if option in error,
896 # returns (0) otherwise.
897
8983140µs my ($argv, $prefix, $argend, $opt, $opctl) = @_;
899
900 print STDERR ("=> find \"$opt\"\n") if $debug;
901
902411µs return (0) unless $opt =~ /^$prefix(.*)$/s;
# spent 9µs making 2 calls to Getopt::Long::CORE:regcomp, avg 4µs/call # spent 2µs making 2 calls to Getopt::Long::CORE:match, avg 1µs/call
903 return (0) if $opt eq "-" && !defined $opctl->{''};
904
905 $opt = $+;
906 my $starter = $1;
907
908 print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
909
910 my $optarg; # value supplied with --opt=value
911 my $rest; # remainder from unbundling
912
913 # If it is a long option, it may include the value.
914 # With getopt_compat, only if not bundling.
91534µs if ( ($starter=~/^$longprefix$/
# spent 4µs making 1 call to Getopt::Long::CORE:regcomp # spent 300ns making 2 calls to Getopt::Long::CORE:match, avg 150ns/call
916 || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
917 && $opt =~ /^([^=]+)=(.*)$/s ) {
918 $opt = $1;
919 $optarg = $2;
920 print STDERR ("=> option \"", $opt,
921 "\", optarg = \"$optarg\"\n") if $debug;
922 }
923
924 #### Look it up ###
925
926 my $tryopt = $opt; # option to try
927
928820µs if ( $bundling && $starter eq '-' ) {
929
930 # To try overrides, obey case ignore.
931 $tryopt = $ignorecase ? lc($opt) : $opt;
932
933 # If bundling == 2, long options can override bundles.
934 if ( $bundling == 2 && length($tryopt) > 1
935 && defined ($opctl->{$tryopt}) ) {
936 print STDERR ("=> $starter$tryopt overrides unbundling\n")
937 if $debug;
938 }
939 else {
940 $tryopt = $opt;
941 # Unbundle single letter option.
942 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
943 $tryopt = substr ($tryopt, 0, 1);
944 $tryopt = lc ($tryopt) if $ignorecase > 1;
945 print STDERR ("=> $starter$tryopt unbundled from ",
946 "$starter$tryopt$rest\n") if $debug;
947 $rest = undef unless $rest ne '';
948 }
949 }
950
951 # Try auto-abbreviation.
952 elsif ( $autoabbrev && $opt ne "" ) {
953 # Sort the possible long option names.
95412µs my @names = sort(keys (%$opctl));
# spent 2µs making 1 call to Getopt::Long::CORE:sort
955 # Downcase if allowed.
956 $opt = lc ($opt) if $ignorecase;
957 $tryopt = $opt;
958 # Turn option name into pattern.
959 my $pat = quotemeta ($opt);
960 # Look up in option names.
96144µs my @hits = grep (/^$pat/, @names);
# spent 3µs making 2 calls to Getopt::Long::CORE:regcomp, avg 2µs/call # spent 1µs making 2 calls to Getopt::Long::CORE:match, avg 500ns/call
962 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
963 "out of ", scalar(@names), "\n") if $debug;
964
965 # Check for ambiguous results.
966 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
967 # See if all matches are for the same option.
968 my %hit;
969 foreach ( @hits ) {
970 my $hit = $_;
971 $hit = $opctl->{$hit}->[CTL_CNAME]
972 if defined $opctl->{$hit}->[CTL_CNAME];
973 $hit{$hit} = 1;
974 }
975 # Remove auto-supplied options (version, help).
976 if ( keys(%hit) == 2 ) {
977 if ( $auto_version && exists($hit{version}) ) {
978 delete $hit{version};
979 }
980 elsif ( $auto_help && exists($hit{help}) ) {
981 delete $hit{help};
982 }
983 }
984 # Now see if it really is ambiguous.
985 unless ( keys(%hit) == 1 ) {
986 return (0) if $passthrough;
987 warn ("Option ", $opt, " is ambiguous (",
988 join(", ", @hits), ")\n");
989 $error++;
990 return (1, undef);
991 }
992 @hits = keys(%hit);
993 }
994
995 # Complete the option name, if appropriate.
9963900ns if ( @hits == 1 && $hits[0] ne $opt ) {
997 $tryopt = $hits[0];
998 $tryopt = lc ($tryopt) if $ignorecase;
999 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1000 if $debug;
1001 }
1002 }
1003
1004 # Map to all lowercase if ignoring case.
1005 elsif ( $ignorecase ) {
1006 $tryopt = lc ($opt);
1007 }
1008
1009 # Check validity by fetching the info.
1010 my $ctl = $opctl->{$tryopt};
1011 unless ( defined $ctl ) {
1012 return (0) if $passthrough;
1013 # Pretend one char when bundling.
1014 if ( $bundling == 1 && length($starter) == 1 ) {
1015 $opt = substr($opt,0,1);
1016 unshift (@$argv, $starter.$rest) if defined $rest;
1017 }
1018 if ( $opt eq "" ) {
1019 warn ("Missing option after ", $starter, "\n");
1020 }
1021 else {
1022 warn ("Unknown option: ", $opt, "\n");
1023 }
1024 $error++;
1025 return (1, undef);
1026 }
1027 # Apparently valid.
1028 $opt = $tryopt;
1029 print STDERR ("=> found ", OptCtl($ctl),
1030 " for \"", $opt, "\"\n") if $debug;
1031
1032 #### Determine argument status ####
1033
1034 # If it is an option w/o argument, we're almost finished with it.
1035 my $type = $ctl->[CTL_TYPE];
1036 my $arg;
1037
1038 if ( $type eq '' || $type eq '!' || $type eq '+' ) {
1039 if ( defined $optarg ) {
1040 return (0) if $passthrough;
1041 warn ("Option ", $opt, " does not take an argument\n");
1042 $error++;
1043 undef $opt;
1044 }
1045 elsif ( $type eq '' || $type eq '+' ) {
1046 # Supply explicit value.
1047 $arg = 1;
1048 }
1049 else {
1050 $opt =~ s/^no-?//i; # strip NO prefix
1051 $arg = 0; # supply explicit value
1052 }
1053 unshift (@$argv, $starter.$rest) if defined $rest;
1054 return (1, $opt, $ctl, $arg);
1055 }
1056
1057 # Get mandatory status and type info.
1058 my $mand = $ctl->[CTL_AMIN];
1059
1060 # Check if there is an option argument available.
1061 if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
1062 return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
1063 $optarg = 0 unless $type eq 's';
1064 }
1065
1066 # Check if there is an option argument available.
1067 if ( defined $optarg
1068 ? ($optarg eq '')
1069 : !(defined $rest || @$argv > 0) ) {
1070 # Complain if this option needs an argument.
1071# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1072 if ( $mand ) {
1073 return (0) if $passthrough;
1074 warn ("Option ", $opt, " requires an argument\n");
1075 $error++;
1076 return (1, undef);
1077 }
1078 if ( $type eq 'I' ) {
1079 # Fake incremental type.
1080 my @c = @$ctl;
1081 $c[CTL_TYPE] = '+';
1082 return (1, $opt, \@c, 1);
1083 }
1084 return (1, $opt, $ctl,
1085 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1086 $type eq 's' ? '' : 0);
1087 }
1088
1089 # Get (possibly optional) argument.
1090 $arg = (defined $rest ? $rest
1091 : (defined $optarg ? $optarg : shift (@$argv)));
1092
1093 # Get key if this is a "name=value" pair for a hash option.
1094 my $key;
1095 if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1096 ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1097 : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1098 ($mand ? undef : ($type eq 's' ? "" : 1)));
1099 if (! defined $arg) {
1100 warn ("Option $opt, key \"$key\", requires a value\n");
1101 $error++;
1102 # Push back.
1103 unshift (@$argv, $starter.$rest) if defined $rest;
1104 return (1, undef);
1105 }
1106 }
1107
1108 #### Check if the argument is valid for this option ####
1109
1110 my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1111
1112212µs if ( $type eq 's' ) { # string
1113 # A mandatory string takes anything.
1114 return (1, $opt, $ctl, $arg, $key) if $mand;
1115
1116 # Same for optional string as a hash value
1117 return (1, $opt, $ctl, $arg, $key)
1118 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1119
1120 # An optional string takes almost anything.
1121 return (1, $opt, $ctl, $arg, $key)
1122 if defined $optarg || defined $rest;
1123 return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1124
1125 # Check for option or option list terminator.
1126 if ($arg eq $argend ||
1127 $arg =~ /^$prefix.+/) {
1128 # Push back.
1129 unshift (@$argv, $arg);
1130 # Supply empty value.
1131 $arg = '';
1132 }
1133 }
1134
1135 elsif ( $type eq 'i' # numeric/integer
1136 || $type eq 'I' # numeric/integer w/ incr default
1137 || $type eq 'o' ) { # dec/oct/hex/bin value
1138
1139 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1140
114126µs28µs if ( $bundling && defined $rest
# spent 7µs making 1 call to Getopt::Long::CORE:regcomp # spent 1µs making 1 call to Getopt::Long::CORE:match
1142 && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1143 ($key, $arg, $rest) = ($1, $2, $+);
1144 chop($key) if $key;
1145 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1146 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1147 }
1148 elsif ( $arg =~ /^$o_valid$/si ) {
1149 $arg =~ tr/_//d;
1150 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1151 }
1152 else {
1153 if ( defined $optarg || $mand ) {
1154 if ( $passthrough ) {
1155 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1156 unless defined $optarg;
1157 return (0);
1158 }
1159 warn ("Value \"", $arg, "\" invalid for option ",
1160 $opt, " (",
1161 $type eq 'o' ? "extended " : '',
1162 "number expected)\n");
1163 $error++;
1164 # Push back.
1165 unshift (@$argv, $starter.$rest) if defined $rest;
1166 return (1, undef);
1167 }
1168 else {
1169 # Push back.
1170 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1171 if ( $type eq 'I' ) {
1172 # Fake incremental type.
1173 my @c = @$ctl;
1174 $c[CTL_TYPE] = '+';
1175 return (1, $opt, \@c, 1);
1176 }
1177 # Supply default value.
1178 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1179 }
1180 }
1181 }
1182
1183 elsif ( $type eq 'f' ) { # real number, int is also ok
1184 # We require at least one digit before a point or 'e',
1185 # and at least one digit following the point and 'e'.
1186 # [-]NN[.NN][eNN]
1187 my $o_valid = PAT_FLOAT;
1188 if ( $bundling && defined $rest &&
1189 $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1190 $arg =~ tr/_//d;
1191 ($key, $arg, $rest) = ($1, $2, $+);
1192 chop($key) if $key;
1193 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1194 }
1195 elsif ( $arg =~ /^$o_valid$/ ) {
1196 $arg =~ tr/_//d;
1197 }
1198 else {
1199 if ( defined $optarg || $mand ) {
1200 if ( $passthrough ) {
1201 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1202 unless defined $optarg;
1203 return (0);
1204 }
1205 warn ("Value \"", $arg, "\" invalid for option ",
1206 $opt, " (real number expected)\n");
1207 $error++;
1208 # Push back.
1209 unshift (@$argv, $starter.$rest) if defined $rest;
1210 return (1, undef);
1211 }
1212 else {
1213 # Push back.
1214 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1215 # Supply default value.
1216 $arg = 0.0;
1217 }
1218 }
1219 }
1220 else {
1221 die("Getopt::Long internal error (Can't happen)\n");
1222 }
1223 return (1, $opt, $ctl, $arg, $key);
1224}
1225
1226sub ValidValue ($$$$$) {
1227 my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1228
1229 if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1230 return 0 unless $arg =~ /[^=]+=(.*)/;
1231 $arg = $1;
1232 }
1233
1234 my $type = $ctl->[CTL_TYPE];
1235
1236 if ( $type eq 's' ) { # string
1237 # A mandatory string takes anything.
1238 return (1) if $mand;
1239
1240 return (1) if $arg eq "-";
1241
1242 # Check for option or option list terminator.
1243 return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1244 return 1;
1245 }
1246
1247 elsif ( $type eq 'i' # numeric/integer
1248 || $type eq 'I' # numeric/integer w/ incr default
1249 || $type eq 'o' ) { # dec/oct/hex/bin value
1250
1251 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1252 return $arg =~ /^$o_valid$/si;
1253 }
1254
1255 elsif ( $type eq 'f' ) { # real number, int is also ok
1256 # We require at least one digit before a point or 'e',
1257 # and at least one digit following the point and 'e'.
1258 # [-]NN[.NN][eNN]
1259 my $o_valid = PAT_FLOAT;
1260 return $arg =~ /^$o_valid$/;
1261 }
1262 die("ValidValue: Cannot happen\n");
1263}
1264
1265# Getopt::Long Configuration.
1266
# spent 3µs within Getopt::Long::Configure which was called: # once (3µs+0s) by main::BEGIN@10 at line 133
sub Configure (@) {
126764µs my (@options) = @_;
1268
1269 my $prevconfig =
1270 [ $error, $debug, $major_version, $minor_version,
1271 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1272 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1273 $longprefix ];
1274
1275 if ( ref($options[0]) eq 'ARRAY' ) {
1276 ( $error, $debug, $major_version, $minor_version,
1277 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1278 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1279 $longprefix ) = @{shift(@options)};
1280 }
1281
1282 my $opt;
1283 foreach $opt ( @options ) {
1284 my $try = lc ($opt);
1285 my $action = 1;
1286 if ( $try =~ /^no_?(.*)$/s ) {
1287 $action = 0;
1288 $try = $+;
1289 }
1290 if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
1291 ConfigDefaults ();
1292 }
1293 elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1294 local $ENV{POSIXLY_CORRECT};
1295 $ENV{POSIXLY_CORRECT} = 1 if $action;
1296 ConfigDefaults ();
1297 }
1298 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1299 $autoabbrev = $action;
1300 }
1301 elsif ( $try eq 'getopt_compat' ) {
1302 $getopt_compat = $action;
1303 $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1304 }
1305 elsif ( $try eq 'gnu_getopt' ) {
1306 if ( $action ) {
1307 $gnu_compat = 1;
1308 $bundling = 1;
1309 $getopt_compat = 0;
1310 $genprefix = "(--|-)";
1311 $order = $PERMUTE;
1312 }
1313 }
1314 elsif ( $try eq 'gnu_compat' ) {
1315 $gnu_compat = $action;
1316 }
1317 elsif ( $try =~ /^(auto_?)?version$/ ) {
1318 $auto_version = $action;
1319 }
1320 elsif ( $try =~ /^(auto_?)?help$/ ) {
1321 $auto_help = $action;
1322 }
1323 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1324 $ignorecase = $action;
1325 }
1326 elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1327 $ignorecase = $action ? 2 : 0;
1328 }
1329 elsif ( $try eq 'bundling' ) {
1330 $bundling = $action;
1331 }
1332 elsif ( $try eq 'bundling_override' ) {
1333 $bundling = $action ? 2 : 0;
1334 }
1335 elsif ( $try eq 'require_order' ) {
1336 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1337 }
1338 elsif ( $try eq 'permute' ) {
1339 $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1340 }
1341 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1342 $passthrough = $action;
1343 }
1344 elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1345 $genprefix = $1;
1346 # Turn into regexp. Needs to be parenthesized!
1347 $genprefix = "(" . quotemeta($genprefix) . ")";
1348 eval { '' =~ /$genprefix/; };
1349 die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1350 }
1351 elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1352 $genprefix = $1;
1353 # Parenthesize if needed.
1354 $genprefix = "(" . $genprefix . ")"
1355 unless $genprefix =~ /^\(.*\)$/;
1356 eval { '' =~ m"$genprefix"; };
1357 die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1358 }
1359 elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1360 $longprefix = $1;
1361 # Parenthesize if needed.
1362 $longprefix = "(" . $longprefix . ")"
1363 unless $longprefix =~ /^\(.*\)$/;
1364 eval { '' =~ m"$longprefix"; };
1365 die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
1366 }
1367 elsif ( $try eq 'debug' ) {
1368 $debug = $action;
1369 }
1370 else {
1371 die("Getopt::Long: unknown config parameter \"$opt\"")
1372 }
1373 }
1374 $prevconfig;
1375}
1376
1377# Deprecated name.
1378sub config (@) {
1379 Configure (@_);
1380}
1381
1382# Issue a standard message for --version.
1383#
1384# The arguments are mostly the same as for Pod::Usage::pod2usage:
1385#
1386# - a number (exit value)
1387# - a string (lead in message)
1388# - a hash with options. See Pod::Usage for details.
1389#
1390sub VersionMessage(@) {
1391 # Massage args.
1392 my $pa = setup_pa_args("version", @_);
1393
1394 my $v = $main::VERSION;
1395 my $fh = $pa->{-output} ||
1396 ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1397
1398 print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1399 $0, defined $v ? " version $v" : (),
1400 "\n",
1401 "(", __PACKAGE__, "::", "GetOptions",
1402 " version ",
1403 defined($Getopt::Long::VERSION_STRING)
1404 ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1405 " Perl version ",
1406 $] >= 5.006 ? sprintf("%vd", $^V) : $],
1407 ")\n");
1408 exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1409}
1410
1411# Issue a standard message for --help.
1412#
1413# The arguments are the same as for Pod::Usage::pod2usage:
1414#
1415# - a number (exit value)
1416# - a string (lead in message)
1417# - a hash with options. See Pod::Usage for details.
1418#
1419sub HelpMessage(@) {
1420 eval {
1421 require Pod::Usage;
1422 import Pod::Usage;
1423 1;
1424 } || die("Cannot provide help: cannot load Pod::Usage\n");
1425
1426 # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1427 pod2usage(setup_pa_args("help", @_));
1428
1429}
1430
1431# Helper routine to set up a normalized hash ref to be used as
1432# argument to pod2usage.
1433sub setup_pa_args($@) {
1434 my $tag = shift; # who's calling
1435
1436 # If called by direct binding to an option, it will get the option
1437 # name and value as arguments. Remove these, if so.
1438 @_ = () if @_ == 2 && $_[0] eq $tag;
1439
1440 my $pa;
1441 if ( @_ > 1 ) {
1442 $pa = { @_ };
1443 }
1444 else {
1445 $pa = shift || {};
1446 }
1447
1448 # At this point, $pa can be a number (exit value), string
1449 # (message) or hash with options.
1450
1451 if ( UNIVERSAL::isa($pa, 'HASH') ) {
1452 # Get rid of -msg vs. -message ambiguity.
1453 $pa->{-message} = $pa->{-msg};
1454 delete($pa->{-msg});
1455 }
1456 elsif ( $pa =~ /^-?\d+$/ ) {
1457 $pa = { -exitval => $pa };
1458 }
1459 else {
1460 $pa = { -message => $pa };
1461 }
1462
1463 # These are _our_ defaults.
1464 $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1465 $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1466 $pa;
1467}
1468
1469# Sneak way to know what version the user requested.
1470sub VERSION {
1471 $requested_version = $_[1];
1472 shift->SUPER::VERSION(@_);
1473}
1474
1475package Getopt::Long::CallBack;
1476
1477sub new {
1478 my ($pkg, %atts) = @_;
1479 bless { %atts }, $pkg;
1480}
1481
1482sub name {
1483 my $self = shift;
1484 ''.$self->{name};
1485}
1486
1487use overload
1488 # Treat this object as an ordinary string for legacy API.
1489126µs
# spent 33µs (7+26) within Getopt::Long::CallBack::BEGIN@1489 which was called: # once (7µs+26µs) by main::BEGIN@10 at line 1490
'""' => \&name,
# spent 26µs making 1 call to overload::import
1490252µs133µs fallback => 1;
# spent 33µs making 1 call to Getopt::Long::CallBack::BEGIN@1489
1491
149216µs1;
1493
1494################ Documentation ################
1495
 
# spent 30µs within Getopt::Long::CORE:match which was called 17 times, avg 2µs/call: # 2 times (4µs+0s) by Getopt::Long::ParseOptionSpec at line 774, avg 2µs/call # 2 times (4µs+0s) by Getopt::Long::ParseOptionSpec at line 834, avg 2µs/call # 2 times (2µs+0s) by Getopt::Long::FindOption at line 902, avg 1µs/call # 2 times (2µs+0s) by Getopt::Long::GetOptionsFromArray at line 344, avg 1µs/call # 2 times (1µs+0s) by Getopt::Long::FindOption at line 961, avg 500ns/call # 2 times (1µs+0s) by Getopt::Long::ParseOptionSpec at line 818, avg 500ns/call # 2 times (300ns+0s) by Getopt::Long::FindOption at line 915, avg 150ns/call # once (12µs+0s) by main::BEGIN@10 at line 123 # once (2µs+0s) by Getopt::Long::GetOptionsFromArray at line 322 # once (1µs+0s) by Getopt::Long::FindOption at line 1141
sub Getopt::Long::CORE:match; # opcode
# spent 35µs within Getopt::Long::CORE:regcomp which was called 8 times, avg 4µs/call: # 2 times (12µs+0s) by Getopt::Long::GetOptionsFromArray at line 344, avg 6µs/call # 2 times (9µs+0s) by Getopt::Long::FindOption at line 902, avg 4µs/call # 2 times (3µs+0s) by Getopt::Long::FindOption at line 961, avg 2µs/call # once (7µs+0s) by Getopt::Long::FindOption at line 1141 # once (4µs+0s) by Getopt::Long::FindOption at line 915
sub Getopt::Long::CORE:regcomp; # opcode
# spent 2µs within Getopt::Long::CORE:sort which was called: # once (2µs+0s) by Getopt::Long::FindOption at line 954
sub Getopt::Long::CORE:sort; # opcode
Report produced by the NYTProf 4.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.