← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:17 2017

Filename/usr/local/lib/perl5/5.24/Getopt/Long.pm
StatementsExecuted 1760 statements in 31.0ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11113.1ms18.3msGetopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
38114.03ms4.37msGetopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
1113.21ms5.10msGetopt::Long::CallBack::::BEGIN@1547Getopt::Long::CallBack::BEGIN@1547
1113.00ms4.36msGetopt::Long::::BEGIN@219 Getopt::Long::BEGIN@219
129121599µs599µsGetopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
411306µs401µsGetopt::Long::::FindOption Getopt::Long::FindOption
222283µs344µsGetopt::Long::::Configure Getopt::Long::Configure
4531263µs263µsGetopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
22293µs4.56msGetopt::Long::::import Getopt::Long::import
11143µs43µsGetopt::Long::::BEGIN@15 Getopt::Long::BEGIN@15
11139µs39µsGetopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
11136µs220µsGetopt::Long::::BEGIN@247 Getopt::Long::BEGIN@247
11134µs225µsGetopt::Long::::BEGIN@239 Getopt::Long::BEGIN@239
11129µs29µsGetopt::Long::::GetOptions Getopt::Long::GetOptions
11127µs176µsGetopt::Long::::BEGIN@240 Getopt::Long::BEGIN@240
11127µs204µsGetopt::Long::::BEGIN@234 Getopt::Long::BEGIN@234
11127µs212µsGetopt::Long::::BEGIN@235 Getopt::Long::BEGIN@235
11126µs218µsGetopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
11126µs204µsGetopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
11126µs26µsGetopt::Long::CallBack::::newGetopt::Long::CallBack::new
11125µs219µsGetopt::Long::::BEGIN@248 Getopt::Long::BEGIN@248
11123µs142µsGetopt::Long::::BEGIN@25 Getopt::Long::BEGIN@25
11122µs110µsGetopt::Long::::BEGIN@19 Getopt::Long::BEGIN@19
11122µs218µsGetopt::Long::::BEGIN@258 Getopt::Long::BEGIN@258
11121µs400µsGetopt::Long::::BEGIN@48 Getopt::Long::BEGIN@48
11120µs221µsGetopt::Long::::BEGIN@233 Getopt::Long::BEGIN@233
11120µs173µsGetopt::Long::::BEGIN@229 Getopt::Long::BEGIN@229
11119µs194µsGetopt::Long::::BEGIN@231 Getopt::Long::BEGIN@231
11118µs34µsGetopt::Long::::BEGIN@17 Getopt::Long::BEGIN@17
11117µs210µsGetopt::Long::::BEGIN@237 Getopt::Long::BEGIN@237
11117µs274µsGetopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
11117µs346µsGetopt::Long::::BEGIN@51 Getopt::Long::BEGIN@51
11117µs70µsGetopt::Long::::BEGIN@22 Getopt::Long::BEGIN@22
11117µs536µsGetopt::Long::::BEGIN@45 Getopt::Long::BEGIN@45
11113µs13µsGetopt::Long::::BEGIN@37 Getopt::Long::BEGIN@37
0000s0sGetopt::Long::CallBack::::nameGetopt::Long::CallBack::name
0000s0sGetopt::Long::::GetOptionsFromString Getopt::Long::GetOptionsFromString
0000s0sGetopt::Long::::HelpMessage Getopt::Long::HelpMessage
0000s0sGetopt::Long::::OptCtl Getopt::Long::OptCtl
0000s0sGetopt::Long::Parser::::configure Getopt::Long::Parser::configure
0000s0sGetopt::Long::Parser::::getoptions Getopt::Long::Parser::getoptions
0000s0sGetopt::Long::Parser::::getoptionsfromarray Getopt::Long::Parser::getoptionsfromarray
0000s0sGetopt::Long::Parser::::new Getopt::Long::Parser::new
0000s0sGetopt::Long::::VERSION Getopt::Long::VERSION
0000s0sGetopt::Long::::ValidValue Getopt::Long::ValidValue
0000s0sGetopt::Long::::VersionMessage Getopt::Long::VersionMessage
0000s0sGetopt::Long::::config Getopt::Long::config
0000s0sGetopt::Long::::setup_pa_args Getopt::Long::setup_pa_args
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#! perl
2
3# Getopt::Long.pm -- Universal options parsing
4# Author : Johan Vromans
5# Created On : Tue Sep 11 15:00:12 1990
6# Last Modified By: Johan Vromans
7# Last Modified On: Thu Oct 8 14:57:49 2015
8# Update Count : 1697
9# Status : Released
10
11################ Module Preamble ################
12
13package Getopt::Long;
14
15293µs143µs
# spent 43µs within Getopt::Long::BEGIN@15 which was called: # once (43µs+0s) by main::BEGIN@24 at line 15
use 5.004;
# spent 43µs making 1 call to Getopt::Long::BEGIN@15
16
17278µs249µs
# spent 34µs (18+15) within Getopt::Long::BEGIN@17 which was called: # once (18µs+15µs) by main::BEGIN@24 at line 17
use strict;
# spent 34µs making 1 call to Getopt::Long::BEGIN@17 # spent 15µs making 1 call to strict::import
18
19290µs2198µs
# spent 110µs (22+88) within Getopt::Long::BEGIN@19 which was called: # once (22µs+88µs) by main::BEGIN@24 at line 19
use vars qw($VERSION);
# spent 110µs making 1 call to Getopt::Long::BEGIN@19 # spent 88µs making 1 call to vars::import
2012µs$VERSION = 2.48;
21# For testing versions only.
22293µs2123µs
# spent 70µs (17+53) within Getopt::Long::BEGIN@22 which was called: # once (17µs+53µs) by main::BEGIN@24 at line 22
use vars qw($VERSION_STRING);
# spent 70µs making 1 call to Getopt::Long::BEGIN@22 # spent 53µs making 1 call to vars::import
2312µs$VERSION_STRING = "2.48";
24
25277µs2261µs
# spent 142µs (23+119) within Getopt::Long::BEGIN@25 which was called: # once (23µs+119µs) by main::BEGIN@24 at line 25
use Exporter;
# spent 142µs making 1 call to Getopt::Long::BEGIN@25 # spent 119µs making 1 call to Exporter::import
262191µs2383µs
# spent 204µs (26+179) within Getopt::Long::BEGIN@26 which was called: # once (26µs+179µs) by main::BEGIN@24 at line 26
use vars qw(@ISA @EXPORT @EXPORT_OK);
# spent 204µs making 1 call to Getopt::Long::BEGIN@26 # spent 179µs making 1 call to vars::import
27119µ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 13µs within Getopt::Long::BEGIN@37 which was called: # once (13µs+0s) by main::BEGIN@24 at line 42
BEGIN {
38 # Init immediately so their contents can be used in the 'use vars' below.
3913µs @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
40110µs @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
41 &GetOptionsFromArray &GetOptionsFromString);
42155µs113µs}
# spent 13µs making 1 call to Getopt::Long::BEGIN@37
43
44# User visible variables.
45299µs21.06ms
# spent 536µs (17+520) within Getopt::Long::BEGIN@45 which was called: # once (17µs+520µs) by main::BEGIN@24 at line 45
use vars @EXPORT, @EXPORT_OK;
# spent 536µs making 1 call to Getopt::Long::BEGIN@45 # spent 520µs making 1 call to vars::import
46271µs2532µs
# spent 274µs (17+257) within Getopt::Long::BEGIN@46 which was called: # once (17µs+257µs) by main::BEGIN@24 at line 46
use vars qw($error $debug $major_version $minor_version);
# spent 274µs making 1 call to Getopt::Long::BEGIN@46 # spent 257µs making 1 call to vars::import
47# Deprecated visible variables.
4812µs
# spent 400µs (21+380) within Getopt::Long::BEGIN@48 which was called: # once (21µs+380µs) by main::BEGIN@24 at line 49
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
49174µs2780µs $passthrough);
# spent 400µs making 1 call to Getopt::Long::BEGIN@48 # spent 380µs making 1 call to vars::import
50# Official invisible variables.
5121.49ms2675µs
# spent 346µs (17+329) within Getopt::Long::BEGIN@51 which was called: # once (17µs+329µs) by main::BEGIN@24 at line 51
use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
# spent 346µs making 1 call to Getopt::Long::BEGIN@51 # spent 329µs making 1 call to vars::import
52
53# Really invisible variables.
5412µsmy $bundling_values;
55
56# Public subroutines.
57sub config(@); # deprecated name
58
59# Private subroutines.
60sub ConfigDefaults();
61sub ParseOptionSpec($$);
62sub OptCtl($);
63sub FindOption($$$$$);
64sub ValidValue ($$$$$);
65
66################ Local Variables ################
67
68# $requested_version holds the version that was mentioned in the 'use'
69# or 'require', if any. It can be used to enable or disable specific
70# features.
7112µsmy $requested_version = 0;
72
73################ Resident subroutines ################
74
75
# spent 39µs within Getopt::Long::ConfigDefaults which was called: # once (39µs+0s) by main::BEGIN@24 at line 130
sub ConfigDefaults() {
76 # Handle POSIX compliancy.
7715µs if ( defined $ENV{"POSIXLY_CORRECT"} ) {
78 $genprefix = "(--|-)";
79 $autoabbrev = 0; # no automatic abbrev of options
80 $bundling = 0; # no bundling of single letter switches
81 $getopt_compat = 0; # disallow '+' to start options
82 $order = $REQUIRE_ORDER;
83 }
84 else {
8513µs $genprefix = "(--|-|\\+)";
8612µs $autoabbrev = 1; # automatic abbrev of options
8712µs $bundling = 0; # bundling off by default
8812µs $getopt_compat = 1; # allow '+' to start options
8912µs $order = $PERMUTE;
90 }
91 # Other configurable settings.
9212µs $debug = 0; # for debugging
9312µs $error = 0; # error tally
9412µs $ignorecase = 1; # ignore case when matching options
9512µs $passthrough = 0; # leave unrecognized options alone
9612µs $gnu_compat = 0; # require --opt=val if value is optional
9712µs $longprefix = "(--)"; # what does a long prefix look like
9818µs $bundling_values = 0; # no bundling of values
99}
100
101# Override import.
102
# spent 4.56ms (93µs+4.47) within Getopt::Long::import which was called 2 times, avg 2.28ms/call: # once (47µs+4.03ms) by main::BEGIN@24 at line 24 of /usr/local/bin/sa-learn # once (46µs+439µs) by Razor2::Client::Agent::BEGIN@15 at line 15 of Razor2/Client/Agent.pm
sub import {
10325µs my $pkg = shift; # package
10425µs my @syms = (); # symbols to import
10525µs my @config = (); # configuration
10625µs my $dest = \@syms; # symbols first
107210µs for ( @_ ) {
108 if ( $_ eq ':config' ) {
109 $dest = \@config; # config next
110 next;
111 }
112 push(@$dest, $_); # push
113 }
114 # Hide one level and call super.
11527µs local $Exporter::ExportLevel = 1;
11624µs push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
11725µs $requested_version = 0;
118227µs24.47ms $pkg->SUPER::import(@syms);
# spent 4.47ms making 2 calls to Exporter::import, avg 2.23ms/call
119 # And configure.
120220µs Configure(@config) if @config;
121}
122
123################ Initialization ################
124
125# Values for $order. See GNU getopt.c for details.
12613µs($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
127# Version major/minor numbers.
128160µs139µs($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
# spent 39µs making 1 call to Getopt::Long::CORE:match
129
130111µs139µsConfigDefaults();
# spent 39µs making 1 call to Getopt::Long::ConfigDefaults
131
132################ OO Interface ################
133
134package Getopt::Long::Parser;
135
136# Store a copy of the default configuration. Since ConfigDefaults has
137# just been called, what we get from Configure is the default.
13813µsmy $default_config = do {
13916µs126µs Getopt::Long::Configure ()
# spent 26µs making 1 call to Getopt::Long::Configure
140};
141
142sub new {
143 my $that = shift;
144 my $class = ref($that) || $that;
145 my %atts = @_;
146
147 # Register the callers package.
148 my $self = { caller_pkg => (caller)[0] };
149
150 bless ($self, $class);
151
152 # Process config attributes.
153 if ( defined $atts{config} ) {
154 my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
155 $self->{settings} = Getopt::Long::Configure ($save);
156 delete ($atts{config});
157 }
158 # Else use default config.
159 else {
160 $self->{settings} = $default_config;
161 }
162
163 if ( %atts ) { # Oops
164 die(__PACKAGE__.": unhandled attributes: ".
165 join(" ", sort(keys(%atts)))."\n");
166 }
167
168 $self;
169}
170
171sub configure {
172 my ($self) = shift;
173
174 # Restore settings, merge new settings in.
175 my $save = Getopt::Long::Configure ($self->{settings}, @_);
176
177 # Restore orig config and save the new config.
178 $self->{settings} = Getopt::Long::Configure ($save);
179}
180
181sub getoptions {
182 my ($self) = shift;
183
184 return $self->getoptionsfromarray(\@ARGV, @_);
185}
186
187sub getoptionsfromarray {
188 my ($self) = shift;
189
190 # Restore config settings.
191 my $save = Getopt::Long::Configure ($self->{settings});
192
193 # Call main routine.
194 my $ret = 0;
195 $Getopt::Long::caller = $self->{caller_pkg};
196
197 eval {
198 # Locally set exception handler to default, otherwise it will
199 # be called implicitly here, and again explicitly when we try
200 # to deliver the messages.
201 local ($SIG{__DIE__}) = 'DEFAULT';
202 $ret = Getopt::Long::GetOptionsFromArray (@_);
203 };
204
205 # Restore saved settings.
206 Getopt::Long::Configure ($save);
207
208 # Handle errors and return value.
209 die ($@) if $@;
210 return $ret;
211}
212
213package Getopt::Long;
214
215################ Back to Normal ################
216
217# Indices in option control info.
218# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
2192355µs24.60ms
# spent 4.36ms (3.00+1.35) within Getopt::Long::BEGIN@219 which was called: # once (3.00ms+1.35ms) by main::BEGIN@24 at line 219
use constant CTL_TYPE => 0;
# spent 4.36ms making 1 call to Getopt::Long::BEGIN@219 # spent 242µs making 1 call to constant::import
220#use constant CTL_TYPE_FLAG => '';
221#use constant CTL_TYPE_NEG => '!';
222#use constant CTL_TYPE_INCR => '+';
223#use constant CTL_TYPE_INT => 'i';
224#use constant CTL_TYPE_INTINC => 'I';
225#use constant CTL_TYPE_XINT => 'o';
226#use constant CTL_TYPE_FLOAT => 'f';
227#use constant CTL_TYPE_STRING => 's';
228
229278µs2327µs
# spent 173µs (20+154) within Getopt::Long::BEGIN@229 which was called: # once (20µs+154µs) by main::BEGIN@24 at line 229
use constant CTL_CNAME => 1;
# spent 173µs making 1 call to Getopt::Long::BEGIN@229 # spent 154µs making 1 call to constant::import
230
231270µs2369µs
# spent 194µs (19+175) within Getopt::Long::BEGIN@231 which was called: # once (19µs+175µs) by main::BEGIN@24 at line 231
use constant CTL_DEFAULT => 2;
# spent 194µs making 1 call to Getopt::Long::BEGIN@231 # spent 175µs making 1 call to constant::import
232
233254µs2422µs
# spent 221µs (20+201) within Getopt::Long::BEGIN@233 which was called: # once (20µs+201µs) by main::BEGIN@24 at line 233
use constant CTL_DEST => 3;
# spent 221µs making 1 call to Getopt::Long::BEGIN@233 # spent 201µs making 1 call to constant::import
234267µs2380µs
# spent 204µs (27+177) within Getopt::Long::BEGIN@234 which was called: # once (27µs+177µs) by main::BEGIN@24 at line 234
use constant CTL_DEST_SCALAR => 0;
# spent 204µs making 1 call to Getopt::Long::BEGIN@234 # spent 177µs making 1 call to constant::import
235272µs2396µs
# spent 212µs (27+185) within Getopt::Long::BEGIN@235 which was called: # once (27µs+185µs) by main::BEGIN@24 at line 235
use constant CTL_DEST_ARRAY => 1;
# spent 212µs making 1 call to Getopt::Long::BEGIN@235 # spent 185µs making 1 call to constant::import
236265µs2410µs
# spent 218µs (26+192) within Getopt::Long::BEGIN@236 which was called: # once (26µs+192µs) by main::BEGIN@24 at line 236
use constant CTL_DEST_HASH => 2;
# spent 218µs making 1 call to Getopt::Long::BEGIN@236 # spent 192µs making 1 call to constant::import
237294µs2403µs
# spent 210µs (17+193) within Getopt::Long::BEGIN@237 which was called: # once (17µs+193µs) by main::BEGIN@24 at line 237
use constant CTL_DEST_CODE => 3;
# spent 210µs making 1 call to Getopt::Long::BEGIN@237 # spent 193µs making 1 call to constant::import
238
239270µs2416µs
# spent 225µs (34+191) within Getopt::Long::BEGIN@239 which was called: # once (34µs+191µs) by main::BEGIN@24 at line 239
use constant CTL_AMIN => 4;
# spent 225µs making 1 call to Getopt::Long::BEGIN@239 # spent 191µs making 1 call to constant::import
240294µs2324µs
# spent 176µs (27+148) within Getopt::Long::BEGIN@240 which was called: # once (27µs+148µs) by main::BEGIN@24 at line 240
use constant CTL_AMAX => 5;
# spent 176µs making 1 call to Getopt::Long::BEGIN@240 # spent 148µs making 1 call to constant::import
241
242# FFU.
243#use constant CTL_RANGE => ;
244#use constant CTL_REPEAT => ;
245
246# Rather liberal patterns to match numbers.
2472120µs2404µs
# spent 220µs (36+184) within Getopt::Long::BEGIN@247 which was called: # once (36µs+184µs) by main::BEGIN@24 at line 247
use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
# spent 220µs making 1 call to Getopt::Long::BEGIN@247 # spent 184µs making 1 call to constant::import
24812µs
# spent 219µs (25+195) within Getopt::Long::BEGIN@248 which was called: # once (25µs+195µs) by main::BEGIN@24 at line 257
use constant PAT_XINT =>
249 "(?:".
250 "[-+]?_*[1-9][0-9_]*".
251 "|".
252 "0x_*[0-9a-f][0-9a-f_]*".
253 "|".
254 "0b_*[01][01_]*".
255 "|".
256 "0[0-7_]*".
2571101µs2414µs ")";
# spent 219µs making 1 call to Getopt::Long::BEGIN@248 # spent 195µs making 1 call to constant::import
25812µs
# spent 218µs (22+197) within Getopt::Long::BEGIN@258 which was called: # once (22µs+197µs) by main::BEGIN@24 at line 263
use constant PAT_FLOAT =>
259 "[-+]?". # optional sign
260 "(?=[0-9.])". # must start with digit or dec.point
261 "[0-9_]*". # digits before the dec.point
262 "(\.[0-9_]+)?". # optional fraction
263115.5ms2415µs "([eE][-+]?[0-9_]+)?"; # optional exponent
# spent 218µs making 1 call to Getopt::Long::BEGIN@258 # spent 197µs making 1 call to constant::import
264
265
# spent 29µs within Getopt::Long::GetOptions which was called: # once (29µs+0s) by main::RUNTIME at line 137 of /usr/local/bin/sa-learn
sub GetOptions(@) {
266 # Shift in default array.
267120µs unshift(@_, \@ARGV);
268 # Try to keep caller() and Carp consistent.
269118µs118.3ms goto &GetOptionsFromArray;
# spent 18.3ms making 1 call to Getopt::Long::GetOptionsFromArray
270}
271
272sub GetOptionsFromString(@) {
273 my ($string) = shift;
274 require Text::ParseWords;
275 my $args = [ Text::ParseWords::shellwords($string) ];
276 $caller ||= (caller)[0]; # current context
277 my $ret = GetOptionsFromArray($args, @_);
278 return ( $ret, $args ) if wantarray;
279 if ( @$args ) {
280 $ret = 0;
281 warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
282 }
283 $ret;
284}
285
286
# spent 18.3ms (13.1+5.19) within Getopt::Long::GetOptionsFromArray which was called: # once (13.1ms+5.19ms) by main::RUNTIME at line 269
sub GetOptionsFromArray(@) {
287
288115µs my ($argv, @optionlist) = @_; # local copy of the option descriptions
28913µs my $argend = '--'; # option list terminator
29013µs my %opctl = (); # table of option specs
29118µs my $pkg = $caller || (caller)[0]; # current context
292 # Needed if linkage is omitted.
29312µs my @ret = (); # accum for non-options
29412µs my %linkage; # linkage
295 my $userlinkage; # user supplied HASH
296 my $opt; # current option
29712µs my $prefix = $genprefix; # current prefix
298
29913µs $error = '';
300
30112µs if ( $debug ) {
302 # Avoid some warnings if debugging.
303 local ($^W) = 0;
304 print STDERR
305 ("Getopt::Long $Getopt::Long::VERSION ",
306 "called from package \"$pkg\".",
307 "\n ",
308 "argv: ",
309 defined($argv)
310 ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv
311 : "<undef>",
312 "\n ",
313 "autoabbrev=$autoabbrev,".
314 "bundling=$bundling,",
315 "bundling_values=$bundling_values,",
316 "getopt_compat=$getopt_compat,",
317 "gnu_compat=$gnu_compat,",
318 "order=$order,",
319 "\n ",
320 "ignorecase=$ignorecase,",
321 "requested_version=$requested_version,",
322 "passthrough=$passthrough,",
323 "genprefix=\"$genprefix\",",
324 "longprefix=\"$longprefix\".",
325 "\n");
326 }
327
328 # Check for ref HASH as first argument.
329 # First argument may be an object. It's OK to use this as long
330 # as it is really a hash underneath.
33113µs $userlinkage = undef;
33213µs if ( @optionlist && ref($optionlist[0]) and
333 UNIVERSAL::isa($optionlist[0],'HASH') ) {
334 $userlinkage = shift (@optionlist);
335 print STDERR ("=> user linkage: $userlinkage\n") if $debug;
336 }
337
338 # See if the first element of the optionlist contains option
339 # starter characters.
340 # Be careful not to interpret '<>' as option starters.
341115µs15µs if ( @optionlist && $optionlist[0] =~ /^\W+$/
# spent 5µs making 1 call to Getopt::Long::CORE:match
342 && !($optionlist[0] eq '<>'
343 && @optionlist > 0
344 && ref($optionlist[1])) ) {
345 $prefix = shift (@optionlist);
346 # Turn into regexp. Needs to be parenthesized!
347 $prefix =~ s/(\W)/\\$1/g;
348 $prefix = "([" . $prefix . "])";
349 print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
350 }
351
352 # Verify correctness of optionlist.
35312µs %opctl = ();
35418µs while ( @optionlist ) {
3553970µs my $opt = shift (@optionlist);
356
3573975µs unless ( defined($opt) ) {
358 $error .= "Undefined argument in option spec\n";
359 next;
360 }
361
362 # Strip leading prefix so people can specify "--foo=i" if they like.
363391.04ms78313µs $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
# spent 193µs making 39 calls to Getopt::Long::CORE:regcomp, avg 5µs/call # spent 120µs making 39 calls to Getopt::Long::CORE:match, avg 3µs/call
364
3653962µs if ( $opt eq '<>' ) {
36612µs if ( (defined $userlinkage)
367 && !(@optionlist > 0 && ref($optionlist[0]))
368 && (exists $userlinkage->{$opt})
369 && ref($userlinkage->{$opt}) ) {
370 unshift (@optionlist, $userlinkage->{$opt});
371 }
37216µs unless ( @optionlist > 0
373 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
374 $error .= "Option spec <> requires a reference to a subroutine\n";
375 # Kill the linkage (to avoid another error).
376 shift (@optionlist)
377 if @optionlist && ref($optionlist[0]);
378 next;
379 }
38013µs $linkage{'<>'} = shift (@optionlist);
38114µs next;
382 }
383
384 # Parse option spec.
38538248µs384.37ms my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
# spent 4.37ms making 38 calls to Getopt::Long::ParseOptionSpec, avg 115µs/call
3863860µs unless ( defined $name ) {
387 # Failed. $orig contains the error message. Sorry for the abuse.
388 $error .= $orig;
389 # Kill the linkage (to avoid another error).
390 shift (@optionlist)
391 if @optionlist && ref($optionlist[0]);
392 next;
393 }
394
395 # If no linkage is supplied in the @optionlist, copy it from
396 # the userlinkage if available.
3973856µs if ( defined $userlinkage ) {
398 unless ( @optionlist > 0 && ref($optionlist[0]) ) {
399 if ( exists $userlinkage->{$orig} &&
400 ref($userlinkage->{$orig}) ) {
401 print STDERR ("=> found userlinkage for \"$orig\": ",
402 "$userlinkage->{$orig}\n")
403 if $debug;
404 unshift (@optionlist, $userlinkage->{$orig});
405 }
406 else {
407 # Do nothing. Being undefined will be handled later.
408 next;
409 }
410 }
411 }
412
413 # Copy the linkage. If omitted, link to global variable.
41438375µs if ( @optionlist > 0 && ref($optionlist[0]) ) {
4153859µs print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
416 if $debug;
41738314µs my $rl = ref($linkage{$orig} = shift (@optionlist));
418
41938161µs if ( $rl eq "ARRAY" ) {
42013µs $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
421 }
422 elsif ( $rl eq "HASH" ) {
423 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
424 }
425 elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
426# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
427# my $t = $linkage{$orig};
428# $$t = $linkage{$orig} = [];
429# }
430# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
431# }
432# else {
433 # Ok.
434# }
435 }
436 elsif ( $rl eq "CODE" ) {
437 # Ok.
438 }
439 else {
440 $error .= "Invalid option linkage for \"$opt\"\n";
441 }
442 }
443 else {
444 # Link to global $opt_XXX variable.
445 # Make sure a valid perl identifier results.
446 my $ov = $orig;
447 $ov =~ s/\W/_/g;
448 if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
449 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
450 if $debug;
451 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
452 }
453 elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
454 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
455 if $debug;
456 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
457 }
458 else {
459 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
460 if $debug;
461 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
462 }
463 }
464
46538179µs if ( $opctl{$name}[CTL_TYPE] eq 'I'
466 && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
467 || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
468 ) {
469 $error .= "Invalid option linkage for \"$opt\"\n";
470 }
471
472 }
473
474116µs15µs $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n"
# spent 5µs making 1 call to UNIVERSAL::isa
475 unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' );
476
477 # Bail out if errors found.
47812µs die ($error) if $error;
47913µs $error = 0;
480
481 # Supply --version and --help support, if needed and allowed.
48218µs if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
483 if ( !defined($opctl{version}) ) {
484 $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
485 $linkage{version} = \&VersionMessage;
486 }
487 $auto_version = 1;
488 }
48913µs if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
490 if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
491 $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
492 $linkage{help} = \&HelpMessage;
493 }
494 $auto_help = 1;
495 }
496
497 # Show the options tables if debugging.
49812µs if ( $debug ) {
499 my ($arrow, $k, $v);
500 $arrow = "=> ";
501 while ( ($k,$v) = each(%opctl) ) {
502 print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
503 $arrow = " ";
504 }
505 }
506
507 # Process argument list
50812µs my $goon = 1;
50919µs while ( $goon && @$argv > 0 ) {
510
511 # Get next argument.
512414µs $opt = shift (@$argv);
51347µs print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
514
515 # Double dash is option list terminator.
516410µs if ( defined($opt) && $opt eq $argend ) {
517 push (@ret, $argend) if $passthrough;
518 last;
519 }
520
521 # Look it up.
522410µs my $tryopt = $opt;
52347µs my $found; # success status
524 my $key; # key (if hash type)
525 my $arg; # option argument
526 my $ctl; # the opctl entry
527
528439µs4401µs ($found, $opt, $ctl, $arg, $key) =
# spent 401µs making 4 calls to Getopt::Long::FindOption, avg 100µs/call
529 FindOption ($argv, $prefix, $argend, $opt, \%opctl);
530
531417µs if ( $found ) {
532
533 # FindOption undefines $opt in case of errors.
53424µs next unless defined $opt;
535
53624µs my $argcnt = 0;
53724µs while ( defined $arg ) {
538
539 # Get the canonical name.
54023µs print STDERR ("=> cname for \"$opt\" is ") if $debug;
54125µs $opt = $ctl->[CTL_CNAME];
54224µs print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
543
54428µs if ( defined $linkage{$opt} ) {
545 print STDERR ("=> ref(\$L{$opt}) -> ",
54623µs ref($linkage{$opt}), "\n") if $debug;
547
548226µs if ( ref($linkage{$opt}) eq 'SCALAR'
549 || ref($linkage{$opt}) eq 'REF' ) {
55016µs if ( $ctl->[CTL_TYPE] eq '+' ) {
551 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
552 if $debug;
553 if ( defined ${$linkage{$opt}} ) {
554 ${$linkage{$opt}} += $arg;
555 }
556 else {
557 ${$linkage{$opt}} = $arg;
558 }
559 }
560 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
561 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
562 " to ARRAY\n")
563 if $debug;
564 my $t = $linkage{$opt};
565 $$t = $linkage{$opt} = [];
566 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
567 if $debug;
568 push (@{$linkage{$opt}}, $arg);
569 }
570 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
571 print STDERR ("=> ref(\$L{$opt}) auto-vivified",
572 " to HASH\n")
573 if $debug;
574 my $t = $linkage{$opt};
575 $$t = $linkage{$opt} = {};
576 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
577 if $debug;
578 $linkage{$opt}->{$key} = $arg;
579 }
580 else {
58112µs print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
582 if $debug;
58327µs ${$linkage{$opt}} = $arg;
584 }
585 }
586 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
587 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
588 if $debug;
589 push (@{$linkage{$opt}}, $arg);
590 }
591 elsif ( ref($linkage{$opt}) eq 'HASH' ) {
592 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
593 if $debug;
594 $linkage{$opt}->{$key} = $arg;
595 }
596 elsif ( ref($linkage{$opt}) eq 'CODE' ) {
59712µs print STDERR ("=> &L{$opt}(\"$opt\"",
598 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
599 ", \"$arg\")\n")
600 if $debug;
60114µs my $eval_error = do {
60213µs local $@;
60318µs local $SIG{__DIE__} = 'DEFAULT';
604119µs eval {
605229µs231µs &{$linkage{$opt}}
# spent 26µs making 1 call to Getopt::Long::CallBack::new # spent 5µs making 1 call to main::__ANON__[/usr/local/bin/sa-learn:94]
606 (Getopt::Long::CallBack->new
607 (name => $opt,
608 ctl => $ctl,
609 opctl => \%opctl,
610 linkage => \%linkage,
611 prefix => $prefix,
612 ),
613 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
614 $arg);
615 };
61617µs $@;
617 };
61812µs print STDERR ("=> die($eval_error)\n")
619 if $debug && $eval_error ne '';
620117µs12µs if ( $eval_error =~ /^!/ ) {
# spent 2µs making 1 call to Getopt::Long::CORE:match
621 if ( $eval_error =~ /^!FINISH\b/ ) {
622 $goon = 0;
623 }
624 }
625 elsif ( $eval_error ne '' ) {
626 warn ($eval_error);
627 $error++;
628 }
629 }
630 else {
631 print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
632 "\" in linkage\n");
633 die("Getopt::Long -- internal error!\n");
634 }
635 }
636 # No entry in linkage means entry in userlinkage.
637 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
638 if ( defined $userlinkage->{$opt} ) {
639 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
640 if $debug;
641 push (@{$userlinkage->{$opt}}, $arg);
642 }
643 else {
644 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
645 if $debug;
646 $userlinkage->{$opt} = [$arg];
647 }
648 }
649 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
650 if ( defined $userlinkage->{$opt} ) {
651 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
652 if $debug;
653 $userlinkage->{$opt}->{$key} = $arg;
654 }
655 else {
656 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
657 if $debug;
658 $userlinkage->{$opt} = {$key => $arg};
659 }
660 }
661 else {
662 if ( $ctl->[CTL_TYPE] eq '+' ) {
663 print STDERR ("=> \$L{$opt} += \"$arg\"\n")
664 if $debug;
665 if ( defined $userlinkage->{$opt} ) {
666 $userlinkage->{$opt} += $arg;
667 }
668 else {
669 $userlinkage->{$opt} = $arg;
670 }
671 }
672 else {
673 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
674 $userlinkage->{$opt} = $arg;
675 }
676 }
677
67824µs $argcnt++;
67927µs last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
680 undef($arg);
681
682 # Need more args?
683 if ( $argcnt < $ctl->[CTL_AMIN] ) {
684 if ( @$argv ) {
685 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
686 $arg = shift(@$argv);
687 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
688 $arg =~ tr/_//d;
689 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
690 ? oct($arg)
691 : 0+$arg
692 }
693 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
694 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
695 next;
696 }
697 warn("Value \"$$argv[0]\" invalid for option $opt\n");
698 $error++;
699 }
700 else {
701 warn("Insufficient arguments for option $opt\n");
702 $error++;
703 }
704 }
705
706 # Any more args?
707 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
708 $arg = shift(@$argv);
709 if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) {
710 $arg =~ tr/_//d;
711 $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/
712 ? oct($arg)
713 : 0+$arg
714 }
715 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
716 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
717 next;
718 }
719 }
720 }
721
722 # Not an option. Save it if we $PERMUTE and don't have a <>.
723 elsif ( $order == $PERMUTE ) {
724 # Try non-options call-back.
72523µs my $cb;
72628µs if ( defined ($cb = $linkage{'<>'}) ) {
72724µs print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
728 if $debug;
72928µs my $eval_error = do {
73024µs local $@;
731212µs local $SIG{__DIE__} = 'DEFAULT';
73227µs eval {
733 # The arg to <> cannot be the CallBack object
734 # since it may be passed to other modules that
735 # get confused (e.g., Archive::Tar). Well,
736 # it's not relevant for this callback anyway.
737219µs256µs &$cb($tryopt);
# spent 56µs making 2 calls to main::target, avg 28µs/call
738 };
739214µs $@;
740 };
74124µs print STDERR ("=> die($eval_error)\n")
742 if $debug && $eval_error ne '';
743226µs26µs if ( $eval_error =~ /^!/ ) {
# spent 6µs making 2 calls to Getopt::Long::CORE:match, avg 3µs/call
744 if ( $eval_error =~ /^!FINISH\b/ ) {
745 $goon = 0;
746 }
747 }
748 elsif ( $eval_error ne '' ) {
749 warn ($eval_error);
750 $error++;
751 }
752 }
753 else {
754 print STDERR ("=> saving \"$tryopt\" ",
755 "(not an option, may permute)\n") if $debug;
756 push (@ret, $tryopt);
757 }
75827µs next;
759 }
760
761 # ...otherwise, terminate.
762 else {
763 # Push this one back and exit.
764 unshift (@$argv, $tryopt);
765 return ($error == 0);
766 }
767
768 }
769
770 # Finish.
77113µs if ( @ret && $order == $PERMUTE ) {
772 # Push back accumulated arguments
773 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
774 if $debug;
775 unshift (@$argv, @ret);
776 }
777
778157µs return ($error == 0);
779}
780
781# A readable representation of what's in an optbl.
782sub OptCtl ($) {
783 my ($v) = @_;
784 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
785 "[".
786 join(",",
787 "\"$v[CTL_TYPE]\"",
788 "\"$v[CTL_CNAME]\"",
789 "\"$v[CTL_DEFAULT]\"",
790 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
791 $v[CTL_AMIN] || '',
792 $v[CTL_AMAX] || '',
793# $v[CTL_RANGE] || '',
794# $v[CTL_REPEAT] || '',
795 ). "]";
796}
797
798# Parse an option specification and fill the tables.
799
# spent 4.37ms (4.03+340µs) within Getopt::Long::ParseOptionSpec which was called 38 times, avg 115µs/call: # 38 times (4.03ms+340µs) by Getopt::Long::GetOptionsFromArray at line 385, avg 115µs/call
sub ParseOptionSpec ($$) {
8003870µs my ($opt, $opctl) = @_;
801
802 # Match option spec.
80338619µs38218µs if ( $opt !~ m;^
# spent 218µs making 38 calls to Getopt::Long::CORE:match, avg 6µs/call
804 (
805 # Option name
806 (?: \w+[-\w]* )
807 # Alias names, or "?"
808 (?: \| (?: \? | \w[-\w]* ) )*
809 # Aliases
810 (?: \| (?: [^-|!+=:][^|!+=:]* )? )*
811 )?
812 (
813 # Either modifiers ...
814 [!+]
815 |
816 # ... or a value/dest/repeat specification
817 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
818 |
819 # ... or an optional-with-default spec
820 : (?: -?\d+ | \+ ) [@%]?
821 )?
822 $;x ) {
823 return (undef, "Error in option spec: \"$opt\"\n");
824 }
825
82638104µs my ($names, $spec) = ($1, $2);
8273863µs $spec = '' unless defined $spec;
828
829 # $orig keeps track of the primary name the user specified.
830 # This name will be used for the internal or external linkage.
831 # In other words, if the user specifies "FoO|BaR", it will
832 # match any case combinations of 'foo' and 'bar', but if a global
833 # variable needs to be set, it will be $opt_FoO in the exact case
834 # as specified.
8353858µs my $orig;
836
837 my @names;
83838133µs if ( defined $names ) {
83938146µs @names = split (/\|/, $names);
8403874µs $orig = $names[0];
841 }
842 else {
843 @names = ('');
844 $orig = '';
845 }
846
847 # Construct the opctl entries.
8483856µs my $entry;
84938350µs1540µs if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
# spent 40µs making 15 calls to Getopt::Long::CORE:match, avg 3µs/call
850 # Fields are hard-wired here.
85123207µs $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
852 }
853 elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
854 my $def = $1;
855 my $dest = $2;
856 my $type = $def eq '+' ? 'I' : 'i';
857 $dest ||= '$';
858 $dest = $dest eq '@' ? CTL_DEST_ARRAY
859 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
860 # Fields are hard-wired here.
861 $entry = [$type,$orig,$def eq '+' ? undef : $def,
862 $dest,0,1];
863 }
864 else {
86515292µs1581µs my ($mand, $type, $dest) =
# spent 81µs making 15 calls to Getopt::Long::CORE:match, avg 5µs/call
866 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
8671529µs return (undef, "Cannot repeat while bundling: \"$opt\"\n")
868 if $bundling && defined($4);
8691541µs my ($mi, $cm, $ma) = ($5, $6, $7);
8701524µs return (undef, "{0} is useless in option spec: \"$opt\"\n")
871 if defined($mi) && !$mi && !defined($ma) && !defined($cm);
872
8731525µs $type = 'i' if $type eq 'n';
8741526µs $dest ||= '$';
8751530µs $dest = $dest eq '@' ? CTL_DEST_ARRAY
876 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
877 # Default minargs to 1/0 depending on mand status.
8781528µs $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
879 # Adjust mand status according to minargs.
8801534µs $mand = $mi ? '=' : ':';
881 # Adjust maxargs.
8821529µs $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
8831525µs return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
884 if defined($ma) && !$ma;
8851525µs return (undef, "Max less than min in option spec: \"$opt\"\n")
886 if defined($ma) && $ma < $mi;
887
888 # Fields are hard-wired here.
88915186µs $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
890 }
891
892 # Process all names. First is canonical, the rest are aliases.
8933864µs my $dups = '';
89438126µs foreach ( @names ) {
895
89659104µs $_ = lc ($_)
897 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
898
89959114µs if ( exists $opctl->{$_} ) {
900 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
901 }
902
90359285µs if ( $spec eq '!' ) {
904 $opctl->{"no$_"} = $entry;
905 $opctl->{"no-$_"} = $entry;
906 $opctl->{$_} = [@$entry];
907 $opctl->{$_}->[CTL_TYPE] = '';
908 }
909 else {
91059439µs $opctl->{$_} = $entry;
911 }
912 }
913
9143867µs if ( $dups && $^W ) {
915 foreach ( split(/\n+/, $dups) ) {
916 warn($_."\n");
917 }
918 }
91938582µs ($names[0], $orig);
920}
921
922# Option lookup.
923
# spent 401µs (306+95) within Getopt::Long::FindOption which was called 4 times, avg 100µs/call: # 4 times (306µs+95µs) by Getopt::Long::GetOptionsFromArray at line 528, avg 100µs/call
sub FindOption ($$$$$) {
924
925 # returns (1, $opt, $ctl, $arg, $key) if okay,
926 # returns (1, undef) if option in error,
927 # returns (0) otherwise.
928
929436µs my ($argv, $prefix, $argend, $opt, $opctl) = @_;
930
93146µs print STDERR ("=> find \"$opt\"\n") if $debug;
932
93347µs return (0) unless defined($opt);
9344168µs871µs return (0) unless $opt =~ /^($prefix)(.*)$/s;
# spent 53µs making 4 calls to Getopt::Long::CORE:regcomp, avg 13µs/call # spent 18µs making 4 calls to Getopt::Long::CORE:match, avg 4µs/call
93525µs return (0) if $opt eq "-" && !defined $opctl->{''};
936
937214µs $opt = substr( $opt, length($1) ); # retain taintedness
93825µs my $starter = $1;
939
94023µs print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
941
94223µs my $optarg; # value supplied with --opt=value
943 my $rest; # remainder from unbundling
944
945 # If it is a long option, it may include the value.
946 # With getopt_compat, only if not bundling.
947266µs423µs if ( ($starter=~/^$longprefix$/
# spent 16µs making 2 calls to Getopt::Long::CORE:regcomp, avg 8µs/call # spent 7µs making 2 calls to Getopt::Long::CORE:match, avg 3µs/call
948 || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
949 && (my $oppos = index($opt, '=', 1)) > 0) {
950 my $optorg = $opt;
951 $opt = substr($optorg, 0, $oppos);
952 $optarg = substr($optorg, $oppos + 1); # retain tainedness
953 print STDERR ("=> option \"", $opt,
954 "\", optarg = \"$optarg\"\n") if $debug;
955 }
956
957 #### Look it up ###
958
95925µs my $tryopt = $opt; # option to try
960
96126µs if ( ( $bundling || $bundling_values ) && $starter eq '-' ) {
962
963 # To try overrides, obey case ignore.
964 $tryopt = $ignorecase ? lc($opt) : $opt;
965
966 # If bundling == 2, long options can override bundles.
967 if ( $bundling == 2 && length($tryopt) > 1
968 && defined ($opctl->{$tryopt}) ) {
969 print STDERR ("=> $starter$tryopt overrides unbundling\n")
970 if $debug;
971 }
972
973 # If bundling_values, option may be followed by the value.
974 elsif ( $bundling_values ) {
975 $tryopt = $opt;
976 # Unbundle single letter option.
977 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
978 $tryopt = substr ($tryopt, 0, 1);
979 $tryopt = lc ($tryopt) if $ignorecase > 1;
980 print STDERR ("=> $starter$tryopt unbundled from ",
981 "$starter$tryopt$rest\n") if $debug;
982 # Whatever remains may not be considered an option.
983 $optarg = $rest eq '' ? undef : $rest;
984 $rest = undef;
985 }
986
987 # Split off a single letter and leave the rest for
988 # further processing.
989 else {
990 $tryopt = $opt;
991 # Unbundle single letter option.
992 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
993 $tryopt = substr ($tryopt, 0, 1);
994 $tryopt = lc ($tryopt) if $ignorecase > 1;
995 print STDERR ("=> $starter$tryopt unbundled from ",
996 "$starter$tryopt$rest\n") if $debug;
997 $rest = undef unless $rest ne '';
998 }
999 }
1000
1001 # Try auto-abbreviation.
1002 elsif ( $autoabbrev && $opt ne "" ) {
1003 # Sort the possible long option names.
1004 my @names = sort(keys (%$opctl));
1005 # Downcase if allowed.
1006 $opt = lc ($opt) if $ignorecase;
1007 $tryopt = $opt;
1008 # Turn option name into pattern.
1009 my $pat = quotemeta ($opt);
1010 # Look up in option names.
1011 my @hits = grep (/^$pat/, @names);
1012 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
1013 "out of ", scalar(@names), "\n") if $debug;
1014
1015 # Check for ambiguous results.
1016 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
1017 # See if all matches are for the same option.
1018 my %hit;
1019 foreach ( @hits ) {
1020 my $hit = $opctl->{$_}->[CTL_CNAME]
1021 if defined $opctl->{$_}->[CTL_CNAME];
1022 $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!';
1023 $hit{$hit} = 1;
1024 }
1025 # Remove auto-supplied options (version, help).
1026 if ( keys(%hit) == 2 ) {
1027 if ( $auto_version && exists($hit{version}) ) {
1028 delete $hit{version};
1029 }
1030 elsif ( $auto_help && exists($hit{help}) ) {
1031 delete $hit{help};
1032 }
1033 }
1034 # Now see if it really is ambiguous.
1035 unless ( keys(%hit) == 1 ) {
1036 return (0) if $passthrough;
1037 warn ("Option ", $opt, " is ambiguous (",
1038 join(", ", @hits), ")\n");
1039 $error++;
1040 return (1, undef);
1041 }
1042 @hits = keys(%hit);
1043 }
1044
1045 # Complete the option name, if appropriate.
1046 if ( @hits == 1 && $hits[0] ne $opt ) {
1047 $tryopt = $hits[0];
1048 $tryopt = lc ($tryopt) if $ignorecase;
1049 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1050 if $debug;
1051 }
1052 }
1053
1054 # Map to all lowercase if ignoring case.
1055 elsif ( $ignorecase ) {
1056 $tryopt = lc ($opt);
1057 }
1058
1059 # Check validity by fetching the info.
106026µs my $ctl = $opctl->{$tryopt};
106124µs unless ( defined $ctl ) {
1062 return (0) if $passthrough;
1063 # Pretend one char when bundling.
1064 if ( $bundling == 1 && length($starter) == 1 ) {
1065 $opt = substr($opt,0,1);
1066 unshift (@$argv, $starter.$rest) if defined $rest;
1067 }
1068 if ( $opt eq "" ) {
1069 warn ("Missing option after ", $starter, "\n");
1070 }
1071 else {
1072 warn ("Unknown option: ", $opt, "\n");
1073 }
1074 $error++;
1075 return (1, undef);
1076 }
1077 # Apparently valid.
107824µs $opt = $tryopt;
107923µs print STDERR ("=> found ", OptCtl($ctl),
1080 " for \"", $opt, "\"\n") if $debug;
1081
1082 #### Determine argument status ####
1083
1084 # If it is an option w/o argument, we're almost finished with it.
108524µs my $type = $ctl->[CTL_TYPE];
108624µs my $arg;
1087
108824µs if ( $type eq '' || $type eq '!' || $type eq '+' ) {
108928µs if ( defined $optarg ) {
1090 return (0) if $passthrough;
1091 warn ("Option ", $opt, " does not take an argument\n");
1092 $error++;
1093 undef $opt;
1094 undef $optarg if $bundling_values;
1095 }
1096 elsif ( $type eq '' || $type eq '+' ) {
1097 # Supply explicit value.
109824µs $arg = 1;
1099 }
1100 else {
1101 $opt =~ s/^no-?//i; # strip NO prefix
1102 $arg = 0; # supply explicit value
1103 }
110424µs unshift (@$argv, $starter.$rest) if defined $rest;
1105239µs return (1, $opt, $ctl, $arg);
1106 }
1107
1108 # Get mandatory status and type info.
1109 my $mand = $ctl->[CTL_AMIN];
1110
1111 # Check if there is an option argument available.
1112 if ( $gnu_compat ) {
1113 my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty
1114 $optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) );
1115 return (1, $opt, $ctl, undef)
1116 if (($optargtype == 0) && !$mand);
1117 return (1, $opt, $ctl, $type eq 's' ? '' : 0)
1118 if $optargtype == 1; # --foo= -> return nothing
1119 }
1120
1121 # Check if there is an option argument available.
1122 if ( defined $optarg
1123 ? ($optarg eq '')
1124 : !(defined $rest || @$argv > 0) ) {
1125 # Complain if this option needs an argument.
1126# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1127 if ( $mand ) {
1128 return (0) if $passthrough;
1129 warn ("Option ", $opt, " requires an argument\n");
1130 $error++;
1131 return (1, undef);
1132 }
1133 if ( $type eq 'I' ) {
1134 # Fake incremental type.
1135 my @c = @$ctl;
1136 $c[CTL_TYPE] = '+';
1137 return (1, $opt, \@c, 1);
1138 }
1139 return (1, $opt, $ctl,
1140 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1141 $type eq 's' ? '' : 0);
1142 }
1143
1144 # Get (possibly optional) argument.
1145 $arg = (defined $rest ? $rest
1146 : (defined $optarg ? $optarg : shift (@$argv)));
1147
1148 # Get key if this is a "name=value" pair for a hash option.
1149 my $key;
1150 if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1151 ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1152 : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1153 ($mand ? undef : ($type eq 's' ? "" : 1)));
1154 if (! defined $arg) {
1155 warn ("Option $opt, key \"$key\", requires a value\n");
1156 $error++;
1157 # Push back.
1158 unshift (@$argv, $starter.$rest) if defined $rest;
1159 return (1, undef);
1160 }
1161 }
1162
1163 #### Check if the argument is valid for this option ####
1164
1165 my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1166
1167 if ( $type eq 's' ) { # string
1168 # A mandatory string takes anything.
1169 return (1, $opt, $ctl, $arg, $key) if $mand;
1170
1171 # Same for optional string as a hash value
1172 return (1, $opt, $ctl, $arg, $key)
1173 if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1174
1175 # An optional string takes almost anything.
1176 return (1, $opt, $ctl, $arg, $key)
1177 if defined $optarg || defined $rest;
1178 return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1179
1180 # Check for option or option list terminator.
1181 if ($arg eq $argend ||
1182 $arg =~ /^$prefix.+/) {
1183 # Push back.
1184 unshift (@$argv, $arg);
1185 # Supply empty value.
1186 $arg = '';
1187 }
1188 }
1189
1190 elsif ( $type eq 'i' # numeric/integer
1191 || $type eq 'I' # numeric/integer w/ incr default
1192 || $type eq 'o' ) { # dec/oct/hex/bin value
1193
1194 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1195
1196 if ( $bundling && defined $rest
1197 && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
1198 ($key, $arg, $rest) = ($1, $2, $+);
1199 chop($key) if $key;
1200 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1201 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1202 }
1203 elsif ( $arg =~ /^$o_valid$/si ) {
1204 $arg =~ tr/_//d;
1205 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
1206 }
1207 else {
1208 if ( defined $optarg || $mand ) {
1209 if ( $passthrough ) {
1210 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1211 unless defined $optarg;
1212 return (0);
1213 }
1214 warn ("Value \"", $arg, "\" invalid for option ",
1215 $opt, " (",
1216 $type eq 'o' ? "extended " : '',
1217 "number expected)\n");
1218 $error++;
1219 # Push back.
1220 unshift (@$argv, $starter.$rest) if defined $rest;
1221 return (1, undef);
1222 }
1223 else {
1224 # Push back.
1225 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1226 if ( $type eq 'I' ) {
1227 # Fake incremental type.
1228 my @c = @$ctl;
1229 $c[CTL_TYPE] = '+';
1230 return (1, $opt, \@c, 1);
1231 }
1232 # Supply default value.
1233 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
1234 }
1235 }
1236 }
1237
1238 elsif ( $type eq 'f' ) { # real number, int is also ok
1239 my $o_valid = PAT_FLOAT;
1240 if ( $bundling && defined $rest &&
1241 $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
1242 $arg =~ tr/_//d;
1243 ($key, $arg, $rest) = ($1, $2, $+);
1244 chop($key) if $key;
1245 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
1246 }
1247 elsif ( $arg =~ /^$o_valid$/ ) {
1248 $arg =~ tr/_//d;
1249 }
1250 else {
1251 if ( defined $optarg || $mand ) {
1252 if ( $passthrough ) {
1253 unshift (@$argv, defined $rest ? $starter.$rest : $arg)
1254 unless defined $optarg;
1255 return (0);
1256 }
1257 warn ("Value \"", $arg, "\" invalid for option ",
1258 $opt, " (real number expected)\n");
1259 $error++;
1260 # Push back.
1261 unshift (@$argv, $starter.$rest) if defined $rest;
1262 return (1, undef);
1263 }
1264 else {
1265 # Push back.
1266 unshift (@$argv, defined $rest ? $starter.$rest : $arg);
1267 # Supply default value.
1268 $arg = 0.0;
1269 }
1270 }
1271 }
1272 else {
1273 die("Getopt::Long internal error (Can't happen)\n");
1274 }
1275 return (1, $opt, $ctl, $arg, $key);
1276}
1277
1278sub ValidValue ($$$$$) {
1279 my ($ctl, $arg, $mand, $argend, $prefix) = @_;
1280
1281 if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
1282 return 0 unless $arg =~ /[^=]+=(.*)/;
1283 $arg = $1;
1284 }
1285
1286 my $type = $ctl->[CTL_TYPE];
1287
1288 if ( $type eq 's' ) { # string
1289 # A mandatory string takes anything.
1290 return (1) if $mand;
1291
1292 return (1) if $arg eq "-";
1293
1294 # Check for option or option list terminator.
1295 return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
1296 return 1;
1297 }
1298
1299 elsif ( $type eq 'i' # numeric/integer
1300 || $type eq 'I' # numeric/integer w/ incr default
1301 || $type eq 'o' ) { # dec/oct/hex/bin value
1302
1303 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1304 return $arg =~ /^$o_valid$/si;
1305 }
1306
1307 elsif ( $type eq 'f' ) { # real number, int is also ok
1308 my $o_valid = PAT_FLOAT;
1309 return $arg =~ /^$o_valid$/;
1310 }
1311 die("ValidValue: Cannot happen\n");
1312}
1313
1314# Getopt::Long Configuration.
1315
# spent 344µs (283+62) within Getopt::Long::Configure which was called 2 times, avg 172µs/call: # once (256µs+62µs) by main::RUNTIME at line 86 of /usr/local/bin/sa-learn # once (26µs+0s) by main::BEGIN@24 at line 139
sub Configure (@) {
131628µs my (@options) = @_;
1317
1318214µs my $prevconfig =
1319 [ $error, $debug, $major_version, $minor_version, $caller,
1320 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1321 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1322 $longprefix, $bundling_values ];
1323
132426µs if ( ref($options[0]) eq 'ARRAY' ) {
1325 ( $error, $debug, $major_version, $minor_version, $caller,
1326 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1327 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1328 $longprefix, $bundling_values ) = @{shift(@options)};
1329 }
1330
133124µs my $opt;
1332210µs foreach $opt ( @options ) {
1333512µs my $try = lc ($opt);
1334524µs my $action = 1;
13355108µs546µs if ( $try =~ /^no_?(.*)$/s ) {
# spent 46µs making 5 calls to Getopt::Long::CORE:match, avg 9µs/call
133635µs $action = 0;
1337310µs $try = $+;
1338 }
1339599µs615µs if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
# spent 15µs making 6 calls to Getopt::Long::CORE:match, avg 3µs/call
1340 ConfigDefaults ();
1341 }
1342 elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1343 local $ENV{POSIXLY_CORRECT};
1344 $ENV{POSIXLY_CORRECT} = 1 if $action;
1345 ConfigDefaults ();
1346 }
1347 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
134812µs $autoabbrev = $action;
1349 }
1350 elsif ( $try eq 'getopt_compat' ) {
135112µs $getopt_compat = $action;
135212µs $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1353 }
1354 elsif ( $try eq 'gnu_getopt' ) {
1355 if ( $action ) {
1356 $gnu_compat = 1;
1357 $bundling = 1;
1358 $getopt_compat = 0;
1359 $genprefix = "(--|-)";
1360 $order = $PERMUTE;
1361 $bundling_values = 0;
1362 }
1363 }
1364 elsif ( $try eq 'gnu_compat' ) {
1365 $gnu_compat = $action;
1366 $bundling = 0;
1367 $bundling_values = 1;
1368 }
1369 elsif ( $try =~ /^(auto_?)?version$/ ) {
1370 $auto_version = $action;
1371 }
1372 elsif ( $try =~ /^(auto_?)?help$/ ) {
1373 $auto_help = $action;
1374 }
1375 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
137612µs $ignorecase = $action;
1377 }
1378 elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1379 $ignorecase = $action ? 2 : 0;
1380 }
1381 elsif ( $try eq 'bundling' ) {
138212µs $bundling = $action;
138313µs $bundling_values = 0 if $action;
1384 }
1385 elsif ( $try eq 'bundling_override' ) {
1386 $bundling = $action ? 2 : 0;
1387 $bundling_values = 0 if $action;
1388 }
1389 elsif ( $try eq 'bundling_values' ) {
1390 $bundling_values = $action;
1391 $bundling = 0 if $action;
1392 }
1393 elsif ( $try eq 'require_order' ) {
1394 $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1395 }
1396 elsif ( $try eq 'permute' ) {
139712µs $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1398 }
1399 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1400 $passthrough = $action;
1401 }
1402 elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1403 $genprefix = $1;
1404 # Turn into regexp. Needs to be parenthesized!
1405 $genprefix = "(" . quotemeta($genprefix) . ")";
1406 eval { '' =~ /$genprefix/; };
1407 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1408 }
1409 elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1410 $genprefix = $1;
1411 # Parenthesize if needed.
1412 $genprefix = "(" . $genprefix . ")"
1413 unless $genprefix =~ /^\(.*\)$/;
1414 eval { '' =~ m"$genprefix"; };
1415 die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@;
1416 }
1417 elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1418 $longprefix = $1;
1419 # Parenthesize if needed.
1420 $longprefix = "(" . $longprefix . ")"
1421 unless $longprefix =~ /^\(.*\)$/;
1422 eval { '' =~ m"$longprefix"; };
1423 die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@;
1424 }
1425 elsif ( $try eq 'debug' ) {
1426 $debug = $action;
1427 }
1428 else {
1429 die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n")
1430 }
1431 }
1432228µs $prevconfig;
1433}
1434
1435# Deprecated name.
1436sub config (@) {
1437 Configure (@_);
1438}
1439
1440# Issue a standard message for --version.
1441#
1442# The arguments are mostly the same as for Pod::Usage::pod2usage:
1443#
1444# - a number (exit value)
1445# - a string (lead in message)
1446# - a hash with options. See Pod::Usage for details.
1447#
1448sub VersionMessage(@) {
1449 # Massage args.
1450 my $pa = setup_pa_args("version", @_);
1451
1452 my $v = $main::VERSION;
1453 my $fh = $pa->{-output} ||
1454 ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
1455
1456 print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
1457 $0, defined $v ? " version $v" : (),
1458 "\n",
1459 "(", __PACKAGE__, "::", "GetOptions",
1460 " version ",
1461 defined($Getopt::Long::VERSION_STRING)
1462 ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
1463 " Perl version ",
1464 $] >= 5.006 ? sprintf("%vd", $^V) : $],
1465 ")\n");
1466 exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
1467}
1468
1469# Issue a standard message for --help.
1470#
1471# The arguments are the same as for Pod::Usage::pod2usage:
1472#
1473# - a number (exit value)
1474# - a string (lead in message)
1475# - a hash with options. See Pod::Usage for details.
1476#
1477sub HelpMessage(@) {
1478 eval {
1479 require Pod::Usage;
1480 import Pod::Usage;
1481 1;
1482 } || die("Cannot provide help: cannot load Pod::Usage\n");
1483
1484 # Note that pod2usage will issue a warning if -exitval => NOEXIT.
1485 pod2usage(setup_pa_args("help", @_));
1486
1487}
1488
1489# Helper routine to set up a normalized hash ref to be used as
1490# argument to pod2usage.
1491sub setup_pa_args($@) {
1492 my $tag = shift; # who's calling
1493
1494 # If called by direct binding to an option, it will get the option
1495 # name and value as arguments. Remove these, if so.
1496 @_ = () if @_ == 2 && $_[0] eq $tag;
1497
1498 my $pa;
1499 if ( @_ > 1 ) {
1500 $pa = { @_ };
1501 }
1502 else {
1503 $pa = shift || {};
1504 }
1505
1506 # At this point, $pa can be a number (exit value), string
1507 # (message) or hash with options.
1508
1509 if ( UNIVERSAL::isa($pa, 'HASH') ) {
1510 # Get rid of -msg vs. -message ambiguity.
1511 $pa->{-message} = $pa->{-msg};
1512 delete($pa->{-msg});
1513 }
1514 elsif ( $pa =~ /^-?\d+$/ ) {
1515 $pa = { -exitval => $pa };
1516 }
1517 else {
1518 $pa = { -message => $pa };
1519 }
1520
1521 # These are _our_ defaults.
1522 $pa->{-verbose} = 0 unless exists($pa->{-verbose});
1523 $pa->{-exitval} = 0 unless exists($pa->{-exitval});
1524 $pa;
1525}
1526
1527# Sneak way to know what version the user requested.
1528sub VERSION {
1529 $requested_version = $_[1];
1530 shift->SUPER::VERSION(@_);
1531}
1532
1533package Getopt::Long::CallBack;
1534
1535
# spent 26µs within Getopt::Long::CallBack::new which was called: # once (26µs+0s) by Getopt::Long::GetOptionsFromArray at line 605
sub new {
153618µs my ($pkg, %atts) = @_;
1537121µs bless { %atts }, $pkg;
1538}
1539
1540sub name {
1541 my $self = shift;
1542 ''.$self->{name};
1543}
1544
1545use overload
1546 # Treat this object as an ordinary string for legacy API.
154711.20ms
# spent 5.10ms (3.21+1.90) within Getopt::Long::CallBack::BEGIN@1547 which was called: # once (3.21ms+1.90ms) by main::BEGIN@24 at line 1548
'""' => \&name,
154811.77ms25.25ms fallback => 1;
# spent 5.10ms making 1 call to Getopt::Long::CallBack::BEGIN@1547 # spent 145µs making 1 call to overload::import
1549
1550121µs1;
1551
1552################ Documentation ################
1553
1554=head1 NAME
1555
1556Getopt::Long - Extended processing of command line options
1557
1558=head1 SYNOPSIS
1559
1560 use Getopt::Long;
1561 my $data = "file.dat";
1562 my $length = 24;
1563 my $verbose;
1564 GetOptions ("length=i" => \$length, # numeric
1565 "file=s" => \$data, # string
1566 "verbose" => \$verbose) # flag
1567 or die("Error in command line arguments\n");
1568
1569=head1 DESCRIPTION
1570
1571The Getopt::Long module implements an extended getopt function called
1572GetOptions(). It parses the command line from C<@ARGV>, recognizing
1573and removing specified options and their possible values.
1574
1575This function adheres to the POSIX syntax for command
1576line options, with GNU extensions. In general, this means that options
1577have long names instead of single letters, and are introduced with a
1578double dash "--". Support for bundling of command line options, as was
1579the case with the more traditional single-letter approach, is provided
1580but not enabled by default.
1581
1582=head1 Command Line Options, an Introduction
1583
1584Command line operated programs traditionally take their arguments from
1585the command line, for example filenames or other information that the
1586program needs to know. Besides arguments, these programs often take
1587command line I<options> as well. Options are not necessary for the
1588program to work, hence the name 'option', but are used to modify its
1589default behaviour. For example, a program could do its job quietly,
1590but with a suitable option it could provide verbose information about
1591what it did.
1592
1593Command line options come in several flavours. Historically, they are
1594preceded by a single dash C<->, and consist of a single letter.
1595
1596 -l -a -c
1597
1598Usually, these single-character options can be bundled:
1599
1600 -lac
1601
1602Options can have values, the value is placed after the option
1603character. Sometimes with whitespace in between, sometimes not:
1604
1605 -s 24 -s24
1606
1607Due to the very cryptic nature of these options, another style was
1608developed that used long names. So instead of a cryptic C<-l> one
1609could use the more descriptive C<--long>. To distinguish between a
1610bundle of single-character options and a long one, two dashes are used
1611to precede the option name. Early implementations of long options used
1612a plus C<+> instead. Also, option values could be specified either
1613like
1614
1615 --size=24
1616
1617or
1618
1619 --size 24
1620
1621The C<+> form is now obsolete and strongly deprecated.
1622
1623=head1 Getting Started with Getopt::Long
1624
1625Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
1626first Perl module that provided support for handling the new style of
1627command line options, in particular long option names, hence the Perl5
1628name Getopt::Long. This module also supports single-character options
1629and bundling.
1630
1631To use Getopt::Long from a Perl program, you must include the
1632following line in your Perl program:
1633
1634 use Getopt::Long;
1635
1636This will load the core of the Getopt::Long module and prepare your
1637program for using it. Most of the actual Getopt::Long code is not
1638loaded until you really call one of its functions.
1639
1640In the default configuration, options names may be abbreviated to
1641uniqueness, case does not matter, and a single dash is sufficient,
1642even for long option names. Also, options may be placed between
1643non-option arguments. See L<Configuring Getopt::Long> for more
1644details on how to configure Getopt::Long.
1645
1646=head2 Simple options
1647
1648The most simple options are the ones that take no values. Their mere
1649presence on the command line enables the option. Popular examples are:
1650
1651 --all --verbose --quiet --debug
1652
1653Handling simple options is straightforward:
1654
1655 my $verbose = ''; # option variable with default value (false)
1656 my $all = ''; # option variable with default value (false)
1657 GetOptions ('verbose' => \$verbose, 'all' => \$all);
1658
1659The call to GetOptions() parses the command line arguments that are
1660present in C<@ARGV> and sets the option variable to the value C<1> if
1661the option did occur on the command line. Otherwise, the option
1662variable is not touched. Setting the option value to true is often
1663called I<enabling> the option.
1664
1665The option name as specified to the GetOptions() function is called
1666the option I<specification>. Later we'll see that this specification
1667can contain more than just the option name. The reference to the
1668variable is called the option I<destination>.
1669
1670GetOptions() will return a true value if the command line could be
1671processed successfully. Otherwise, it will write error messages using
1672die() and warn(), and return a false result.
1673
1674=head2 A little bit less simple options
1675
1676Getopt::Long supports two useful variants of simple options:
1677I<negatable> options and I<incremental> options.
1678
1679A negatable option is specified with an exclamation mark C<!> after the
1680option name:
1681
1682 my $verbose = ''; # option variable with default value (false)
1683 GetOptions ('verbose!' => \$verbose);
1684
1685Now, using C<--verbose> on the command line will enable C<$verbose>,
1686as expected. But it is also allowed to use C<--noverbose>, which will
1687disable C<$verbose> by setting its value to C<0>. Using a suitable
1688default value, the program can find out whether C<$verbose> is false
1689by default, or disabled by using C<--noverbose>.
1690
1691An incremental option is specified with a plus C<+> after the
1692option name:
1693
1694 my $verbose = ''; # option variable with default value (false)
1695 GetOptions ('verbose+' => \$verbose);
1696
1697Using C<--verbose> on the command line will increment the value of
1698C<$verbose>. This way the program can keep track of how many times the
1699option occurred on the command line. For example, each occurrence of
1700C<--verbose> could increase the verbosity level of the program.
1701
1702=head2 Mixing command line option with other arguments
1703
1704Usually programs take command line options as well as other arguments,
1705for example, file names. It is good practice to always specify the
1706options first, and the other arguments last. Getopt::Long will,
1707however, allow the options and arguments to be mixed and 'filter out'
1708all the options before passing the rest of the arguments to the
1709program. To stop Getopt::Long from processing further arguments,
1710insert a double dash C<--> on the command line:
1711
1712 --size 24 -- --all
1713
1714In this example, C<--all> will I<not> be treated as an option, but
1715passed to the program unharmed, in C<@ARGV>.
1716
1717=head2 Options with values
1718
1719For options that take values it must be specified whether the option
1720value is required or not, and what kind of value the option expects.
1721
1722Three kinds of values are supported: integer numbers, floating point
1723numbers, and strings.
1724
1725If the option value is required, Getopt::Long will take the
1726command line argument that follows the option and assign this to the
1727option variable. If, however, the option value is specified as
1728optional, this will only be done if that value does not look like a
1729valid command line option itself.
1730
1731 my $tag = ''; # option variable with default value
1732 GetOptions ('tag=s' => \$tag);
1733
1734In the option specification, the option name is followed by an equals
1735sign C<=> and the letter C<s>. The equals sign indicates that this
1736option requires a value. The letter C<s> indicates that this value is
1737an arbitrary string. Other possible value types are C<i> for integer
1738values, and C<f> for floating point values. Using a colon C<:> instead
1739of the equals sign indicates that the option value is optional. In
1740this case, if no suitable value is supplied, string valued options get
1741an empty string C<''> assigned, while numeric options are set to C<0>.
1742
1743=head2 Options with multiple values
1744
1745Options sometimes take several values. For example, a program could
1746use multiple directories to search for library files:
1747
1748 --library lib/stdlib --library lib/extlib
1749
1750To accomplish this behaviour, simply specify an array reference as the
1751destination for the option:
1752
1753 GetOptions ("library=s" => \@libfiles);
1754
1755Alternatively, you can specify that the option can have multiple
1756values by adding a "@", and pass a scalar reference as the
1757destination:
1758
1759 GetOptions ("library=s@" => \$libfiles);
1760
1761Used with the example above, C<@libfiles> (or C<@$libfiles>) would
1762contain two strings upon completion: C<"lib/stdlib"> and
1763C<"lib/extlib">, in that order. It is also possible to specify that
1764only integer or floating point numbers are acceptable values.
1765
1766Often it is useful to allow comma-separated lists of values as well as
1767multiple occurrences of the options. This is easy using Perl's split()
1768and join() operators:
1769
1770 GetOptions ("library=s" => \@libfiles);
1771 @libfiles = split(/,/,join(',',@libfiles));
1772
1773Of course, it is important to choose the right separator string for
1774each purpose.
1775
1776Warning: What follows is an experimental feature.
1777
1778Options can take multiple values at once, for example
1779
1780 --coordinates 52.2 16.4 --rgbcolor 255 255 149
1781
1782This can be accomplished by adding a repeat specifier to the option
1783specification. Repeat specifiers are very similar to the C<{...}>
1784repeat specifiers that can be used with regular expression patterns.
1785For example, the above command line would be handled as follows:
1786
1787 GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
1788
1789The destination for the option must be an array or array reference.
1790
1791It is also possible to specify the minimal and maximal number of
1792arguments an option takes. C<foo=s{2,4}> indicates an option that
1793takes at least two and at most 4 arguments. C<foo=s{1,}> indicates one
1794or more values; C<foo:s{,}> indicates zero or more option values.
1795
1796=head2 Options with hash values
1797
1798If the option destination is a reference to a hash, the option will
1799take, as value, strings of the form I<key>C<=>I<value>. The value will
1800be stored with the specified key in the hash.
1801
1802 GetOptions ("define=s" => \%defines);
1803
1804Alternatively you can use:
1805
1806 GetOptions ("define=s%" => \$defines);
1807
1808When used with command line options:
1809
1810 --define os=linux --define vendor=redhat
1811
1812the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
1813with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
1814also possible to specify that only integer or floating point numbers
1815are acceptable values. The keys are always taken to be strings.
1816
1817=head2 User-defined subroutines to handle options
1818
1819Ultimate control over what should be done when (actually: each time)
1820an option is encountered on the command line can be achieved by
1821designating a reference to a subroutine (or an anonymous subroutine)
1822as the option destination. When GetOptions() encounters the option, it
1823will call the subroutine with two or three arguments. The first
1824argument is the name of the option. (Actually, it is an object that
1825stringifies to the name of the option.) For a scalar or array destination,
1826the second argument is the value to be stored. For a hash destination,
1827the second argument is the key to the hash, and the third argument
1828the value to be stored. It is up to the subroutine to store the value,
1829or do whatever it thinks is appropriate.
1830
1831A trivial application of this mechanism is to implement options that
1832are related to each other. For example:
1833
1834 my $verbose = ''; # option variable with default value (false)
1835 GetOptions ('verbose' => \$verbose,
1836 'quiet' => sub { $verbose = 0 });
1837
1838Here C<--verbose> and C<--quiet> control the same variable
1839C<$verbose>, but with opposite values.
1840
1841If the subroutine needs to signal an error, it should call die() with
1842the desired error message as its argument. GetOptions() will catch the
1843die(), issue the error message, and record that an error result must
1844be returned upon completion.
1845
1846If the text of the error message starts with an exclamation mark C<!>
1847it is interpreted specially by GetOptions(). There is currently one
1848special command implemented: C<die("!FINISH")> will cause GetOptions()
1849to stop processing options, as if it encountered a double dash C<-->.
1850
1851In version 2.37 the first argument to the callback function was
1852changed from string to object. This was done to make room for
1853extensions and more detailed control. The object stringifies to the
1854option name so this change should not introduce compatibility
1855problems.
1856
1857Here is an example of how to access the option name and value from within
1858a subroutine:
1859
1860 GetOptions ('opt=i' => \&handler);
1861 sub handler {
1862 my ($opt_name, $opt_value) = @_;
1863 print("Option name is $opt_name and value is $opt_value\n");
1864 }
1865
1866=head2 Options with multiple names
1867
1868Often it is user friendly to supply alternate mnemonic names for
1869options. For example C<--height> could be an alternate name for
1870C<--length>. Alternate names can be included in the option
1871specification, separated by vertical bar C<|> characters. To implement
1872the above example:
1873
1874 GetOptions ('length|height=f' => \$length);
1875
1876The first name is called the I<primary> name, the other names are
1877called I<aliases>. When using a hash to store options, the key will
1878always be the primary name.
1879
1880Multiple alternate names are possible.
1881
1882=head2 Case and abbreviations
1883
1884Without additional configuration, GetOptions() will ignore the case of
1885option names, and allow the options to be abbreviated to uniqueness.
1886
1887 GetOptions ('length|height=f' => \$length, "head" => \$head);
1888
1889This call will allow C<--l> and C<--L> for the length option, but
1890requires a least C<--hea> and C<--hei> for the head and height options.
1891
1892=head2 Summary of Option Specifications
1893
1894Each option specifier consists of two parts: the name specification
1895and the argument specification.
1896
1897The name specification contains the name of the option, optionally
1898followed by a list of alternative names separated by vertical bar
1899characters.
1900
1901 length option name is "length"
1902 length|size|l name is "length", aliases are "size" and "l"
1903
1904The argument specification is optional. If omitted, the option is
1905considered boolean, a value of 1 will be assigned when the option is
1906used on the command line.
1907
1908The argument specification can be
1909
1910=over 4
1911
1912=item !
1913
1914The option does not take an argument and may be negated by prefixing
1915it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
19161 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
19170 will be assigned). If the option has aliases, this applies to the
1918aliases as well.
1919
1920Using negation on a single letter option when bundling is in effect is
1921pointless and will result in a warning.
1922
1923=item +
1924
1925The option does not take an argument and will be incremented by 1
1926every time it appears on the command line. E.g. C<"more+">, when used
1927with C<--more --more --more>, will increment the value three times,
1928resulting in a value of 3 (provided it was 0 or undefined at first).
1929
1930The C<+> specifier is ignored if the option destination is not a scalar.
1931
1932=item = I<type> [ I<desttype> ] [ I<repeat> ]
1933
1934The option requires an argument of the given type. Supported types
1935are:
1936
1937=over 4
1938
1939=item s
1940
1941String. An arbitrary sequence of characters. It is valid for the
1942argument to start with C<-> or C<-->.
1943
1944=item i
1945
1946Integer. An optional leading plus or minus sign, followed by a
1947sequence of digits.
1948
1949=item o
1950
1951Extended integer, Perl style. This can be either an optional leading
1952plus or minus sign, followed by a sequence of digits, or an octal
1953string (a zero, optionally followed by '0', '1', .. '7'), or a
1954hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
1955insensitive), or a binary string (C<0b> followed by a series of '0'
1956and '1').
1957
1958=item f
1959
1960Real number. For example C<3.14>, C<-6.23E24> and so on.
1961
1962=back
1963
1964The I<desttype> can be C<@> or C<%> to specify that the option is
1965list or a hash valued. This is only needed when the destination for
1966the option value is not otherwise specified. It should be omitted when
1967not needed.
1968
1969The I<repeat> specifies the number of values this option takes per
1970occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
1971
1972I<min> denotes the minimal number of arguments. It defaults to 1 for
1973options with C<=> and to 0 for options with C<:>, see below. Note that
1974I<min> overrules the C<=> / C<:> semantics.
1975
1976I<max> denotes the maximum number of arguments. It must be at least
1977I<min>. If I<max> is omitted, I<but the comma is not>, there is no
1978upper bound to the number of argument values taken.
1979
1980=item : I<type> [ I<desttype> ]
1981
1982Like C<=>, but designates the argument as optional.
1983If omitted, an empty string will be assigned to string values options,
1984and the value zero to numeric options.
1985
1986Note that if a string argument starts with C<-> or C<-->, it will be
1987considered an option on itself.
1988
1989=item : I<number> [ I<desttype> ]
1990
1991Like C<:i>, but if the value is omitted, the I<number> will be assigned.
1992
1993=item : + [ I<desttype> ]
1994
1995Like C<:i>, but if the value is omitted, the current value for the
1996option will be incremented.
1997
1998=back
1999
2000=head1 Advanced Possibilities
2001
2002=head2 Object oriented interface
2003
2004Getopt::Long can be used in an object oriented way as well:
2005
2006 use Getopt::Long;
2007 $p = Getopt::Long::Parser->new;
2008 $p->configure(...configuration options...);
2009 if ($p->getoptions(...options descriptions...)) ...
2010 if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ...
2011
2012Configuration options can be passed to the constructor:
2013
2014 $p = new Getopt::Long::Parser
2015 config => [...configuration options...];
2016
2017=head2 Thread Safety
2018
2019Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
2020I<not> thread safe when using the older (experimental and now
2021obsolete) threads implementation that was added to Perl 5.005.
2022
2023=head2 Documentation and help texts
2024
2025Getopt::Long encourages the use of Pod::Usage to produce help
2026messages. For example:
2027
2028 use Getopt::Long;
2029 use Pod::Usage;
2030
2031 my $man = 0;
2032 my $help = 0;
2033
2034 GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
2035 pod2usage(1) if $help;
2036 pod2usage(-exitval => 0, -verbose => 2) if $man;
2037
2038 __END__
2039
2040 =head1 NAME
2041
2042 sample - Using Getopt::Long and Pod::Usage
2043
2044 =head1 SYNOPSIS
2045
2046 sample [options] [file ...]
2047
2048 Options:
2049 -help brief help message
2050 -man full documentation
2051
2052 =head1 OPTIONS
2053
2054 =over 8
2055
2056 =item B<-help>
2057
2058 Print a brief help message and exits.
2059
2060 =item B<-man>
2061
2062 Prints the manual page and exits.
2063
2064 =back
2065
2066 =head1 DESCRIPTION
2067
2068 B<This program> will read the given input file(s) and do something
2069 useful with the contents thereof.
2070
2071 =cut
2072
2073See L<Pod::Usage> for details.
2074
2075=head2 Parsing options from an arbitrary array
2076
2077By default, GetOptions parses the options that are present in the
2078global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
2079used to parse options from an arbitrary array.
2080
2081 use Getopt::Long qw(GetOptionsFromArray);
2082 $ret = GetOptionsFromArray(\@myopts, ...);
2083
2084When used like this, options and their possible values are removed
2085from C<@myopts>, the global C<@ARGV> is not touched at all.
2086
2087The following two calls behave identically:
2088
2089 $ret = GetOptions( ... );
2090 $ret = GetOptionsFromArray(\@ARGV, ... );
2091
2092This also means that a first argument hash reference now becomes the
2093second argument:
2094
2095 $ret = GetOptions(\%opts, ... );
2096 $ret = GetOptionsFromArray(\@ARGV, \%opts, ... );
2097
2098=head2 Parsing options from an arbitrary string
2099
2100A special entry C<GetOptionsFromString> can be used to parse options
2101from an arbitrary string.
2102
2103 use Getopt::Long qw(GetOptionsFromString);
2104 $ret = GetOptionsFromString($string, ...);
2105
2106The contents of the string are split into arguments using a call to
2107C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
2108global C<@ARGV> is not touched.
2109
2110It is possible that, upon completion, not all arguments in the string
2111have been processed. C<GetOptionsFromString> will, when called in list
2112context, return both the return status and an array reference to any
2113remaining arguments:
2114
2115 ($ret, $args) = GetOptionsFromString($string, ... );
2116
2117If any arguments remain, and C<GetOptionsFromString> was not called in
2118list context, a message will be given and C<GetOptionsFromString> will
2119return failure.
2120
2121As with GetOptionsFromArray, a first argument hash reference now
2122becomes the second argument.
2123
2124=head2 Storing options values in a hash
2125
2126Sometimes, for example when there are a lot of options, having a
2127separate variable for each of them can be cumbersome. GetOptions()
2128supports, as an alternative mechanism, storing options values in a
2129hash.
2130
2131To obtain this, a reference to a hash must be passed I<as the first
2132argument> to GetOptions(). For each option that is specified on the
2133command line, the option value will be stored in the hash with the
2134option name as key. Options that are not actually used on the command
2135line will not be put in the hash, on other words,
2136C<exists($h{option})> (or defined()) can be used to test if an option
2137was used. The drawback is that warnings will be issued if the program
2138runs under C<use strict> and uses C<$h{option}> without testing with
2139exists() or defined() first.
2140
2141 my %h = ();
2142 GetOptions (\%h, 'length=i'); # will store in $h{length}
2143
2144For options that take list or hash values, it is necessary to indicate
2145this by appending an C<@> or C<%> sign after the type:
2146
2147 GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
2148
2149To make things more complicated, the hash may contain references to
2150the actual destinations, for example:
2151
2152 my $len = 0;
2153 my %h = ('length' => \$len);
2154 GetOptions (\%h, 'length=i'); # will store in $len
2155
2156This example is fully equivalent with:
2157
2158 my $len = 0;
2159 GetOptions ('length=i' => \$len); # will store in $len
2160
2161Any mixture is possible. For example, the most frequently used options
2162could be stored in variables while all other options get stored in the
2163hash:
2164
2165 my $verbose = 0; # frequently referred
2166 my $debug = 0; # frequently referred
2167 my %h = ('verbose' => \$verbose, 'debug' => \$debug);
2168 GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
2169 if ( $verbose ) { ... }
2170 if ( exists $h{filter} ) { ... option 'filter' was specified ... }
2171
2172=head2 Bundling
2173
2174With bundling it is possible to set several single-character options
2175at once. For example if C<a>, C<v> and C<x> are all valid options,
2176
2177 -vax
2178
2179will set all three.
2180
2181Getopt::Long supports three styles of bundling. To enable bundling, a
2182call to Getopt::Long::Configure is required.
2183
2184The simplest style of bundling can be enabled with:
2185
2186 Getopt::Long::Configure ("bundling");
2187
2188Configured this way, single-character options can be bundled but long
2189options B<must> always start with a double dash C<--> to avoid
2190ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
2191options,
2192
2193 -vax
2194
2195will set C<a>, C<v> and C<x>, but
2196
2197 --vax
2198
2199will set C<vax>.
2200
2201The second style of bundling lifts this restriction. It can be enabled
2202with:
2203
2204 Getopt::Long::Configure ("bundling_override");
2205
2206Now, C<-vax> will set the option C<vax>.
2207
2208In all of the above cases, option values may be inserted in the
2209bundle. For example:
2210
2211 -h24w80
2212
2213is equivalent to
2214
2215 -h 24 -w 80
2216
2217A third style of bundling allows only values to be bundled with
2218options. It can be enabled with:
2219
2220 Getopt::Long::Configure ("bundling_values");
2221
2222Now, C<-h24> will set the option C<h> to C<24>, but option bundles
2223like C<-vxa> and C<-h24w80> are flagged as errors.
2224
2225Enabling C<bundling_values> will disable the other two styles of
2226bundling.
2227
2228When configured for bundling, single-character options are matched
2229case sensitive while long options are matched case insensitive. To
2230have the single-character options matched case insensitive as well,
2231use:
2232
2233 Getopt::Long::Configure ("bundling", "ignorecase_always");
2234
2235It goes without saying that bundling can be quite confusing.
2236
2237=head2 The lonesome dash
2238
2239Normally, a lone dash C<-> on the command line will not be considered
2240an option. Option processing will terminate (unless "permute" is
2241configured) and the dash will be left in C<@ARGV>.
2242
2243It is possible to get special treatment for a lone dash. This can be
2244achieved by adding an option specification with an empty name, for
2245example:
2246
2247 GetOptions ('' => \$stdio);
2248
2249A lone dash on the command line will now be a legal option, and using
2250it will set variable C<$stdio>.
2251
2252=head2 Argument callback
2253
2254A special option 'name' C<< <> >> can be used to designate a subroutine
2255to handle non-option arguments. When GetOptions() encounters an
2256argument that does not look like an option, it will immediately call this
2257subroutine and passes it one parameter: the argument name. Well, actually
2258it is an object that stringifies to the argument name.
2259
2260For example:
2261
2262 my $width = 80;
2263 sub process { ... }
2264 GetOptions ('width=i' => \$width, '<>' => \&process);
2265
2266When applied to the following command line:
2267
2268 arg1 --width=72 arg2 --width=60 arg3
2269
2270This will call
2271C<process("arg1")> while C<$width> is C<80>,
2272C<process("arg2")> while C<$width> is C<72>, and
2273C<process("arg3")> while C<$width> is C<60>.
2274
2275This feature requires configuration option B<permute>, see section
2276L<Configuring Getopt::Long>.
2277
2278=head1 Configuring Getopt::Long
2279
2280Getopt::Long can be configured by calling subroutine
2281Getopt::Long::Configure(). This subroutine takes a list of quoted
2282strings, each specifying a configuration option to be enabled, e.g.
2283C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
2284matter. Multiple calls to Configure() are possible.
2285
2286Alternatively, as of version 2.24, the configuration options may be
2287passed together with the C<use> statement:
2288
2289 use Getopt::Long qw(:config no_ignore_case bundling);
2290
2291The following options are available:
2292
2293=over 12
2294
2295=item default
2296
2297This option causes all configuration options to be reset to their
2298default values.
2299
2300=item posix_default
2301
2302This option causes all configuration options to be reset to their
2303default values as if the environment variable POSIXLY_CORRECT had
2304been set.
2305
2306=item auto_abbrev
2307
2308Allow option names to be abbreviated to uniqueness.
2309Default is enabled unless environment variable
2310POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
2311
2312=item getopt_compat
2313
2314Allow C<+> to start options.
2315Default is enabled unless environment variable
2316POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
2317
2318=item gnu_compat
2319
2320C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
2321do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
2322C<--opt=> will give option C<opt> and empty value.
2323This is the way GNU getopt_long() does it.
2324
2325=item gnu_getopt
2326
2327This is a short way of setting C<gnu_compat> C<bundling> C<permute>
2328C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
2329fully compatible with GNU getopt_long().
2330
2331=item require_order
2332
2333Whether command line arguments are allowed to be mixed with options.
2334Default is disabled unless environment variable
2335POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
2336
2337See also C<permute>, which is the opposite of C<require_order>.
2338
2339=item permute
2340
2341Whether command line arguments are allowed to be mixed with options.
2342Default is enabled unless environment variable
2343POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
2344Note that C<permute> is the opposite of C<require_order>.
2345
2346If C<permute> is enabled, this means that
2347
2348 --foo arg1 --bar arg2 arg3
2349
2350is equivalent to
2351
2352 --foo --bar arg1 arg2 arg3
2353
2354If an argument callback routine is specified, C<@ARGV> will always be
2355empty upon successful return of GetOptions() since all options have been
2356processed. The only exception is when C<--> is used:
2357
2358 --foo arg1 --bar arg2 -- arg3
2359
2360This will call the callback routine for arg1 and arg2, and then
2361terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
2362
2363If C<require_order> is enabled, options processing
2364terminates when the first non-option is encountered.
2365
2366 --foo arg1 --bar arg2 arg3
2367
2368is equivalent to
2369
2370 --foo -- arg1 --bar arg2 arg3
2371
2372If C<pass_through> is also enabled, options processing will terminate
2373at the first unrecognized option, or non-option, whichever comes
2374first.
2375
2376=item bundling (default: disabled)
2377
2378Enabling this option will allow single-character options to be
2379bundled. To distinguish bundles from long option names, long options
2380I<must> be introduced with C<--> and bundles with C<->.
2381
2382Note that, if you have options C<a>, C<l> and C<all>, and
2383auto_abbrev enabled, possible arguments and option settings are:
2384
2385 using argument sets option(s)
2386 ------------------------------------------
2387 -a, --a a
2388 -l, --l l
2389 -al, -la, -ala, -all,... a, l
2390 --al, --all all
2391
2392The surprising part is that C<--a> sets option C<a> (due to auto
2393completion), not C<all>.
2394
2395Note: disabling C<bundling> also disables C<bundling_override>.
2396
2397=item bundling_override (default: disabled)
2398
2399If C<bundling_override> is enabled, bundling is enabled as with
2400C<bundling> but now long option names override option bundles.
2401
2402Note: disabling C<bundling_override> also disables C<bundling>.
2403
2404B<Note:> Using option bundling can easily lead to unexpected results,
2405especially when mixing long options and bundles. Caveat emptor.
2406
2407=item ignore_case (default: enabled)
2408
2409If enabled, case is ignored when matching option names. If, however,
2410bundling is enabled as well, single character options will be treated
2411case-sensitive.
2412
2413With C<ignore_case>, option specifications for options that only
2414differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
2415duplicates.
2416
2417Note: disabling C<ignore_case> also disables C<ignore_case_always>.
2418
2419=item ignore_case_always (default: disabled)
2420
2421When bundling is in effect, case is ignored on single-character
2422options also.
2423
2424Note: disabling C<ignore_case_always> also disables C<ignore_case>.
2425
2426=item auto_version (default:disabled)
2427
2428Automatically provide support for the B<--version> option if
2429the application did not specify a handler for this option itself.
2430
2431Getopt::Long will provide a standard version message that includes the
2432program name, its version (if $main::VERSION is defined), and the
2433versions of Getopt::Long and Perl. The message will be written to
2434standard output and processing will terminate.
2435
2436C<auto_version> will be enabled if the calling program explicitly
2437specified a version number higher than 2.32 in the C<use> or
2438C<require> statement.
2439
2440=item auto_help (default:disabled)
2441
2442Automatically provide support for the B<--help> and B<-?> options if
2443the application did not specify a handler for this option itself.
2444
2445Getopt::Long will provide a help message using module L<Pod::Usage>. The
2446message, derived from the SYNOPSIS POD section, will be written to
2447standard output and processing will terminate.
2448
2449C<auto_help> will be enabled if the calling program explicitly
2450specified a version number higher than 2.32 in the C<use> or
2451C<require> statement.
2452
2453=item pass_through (default: disabled)
2454
2455With C<pass_through> anything that is unknown, ambiguous or supplied with
2456an invalid option will not be flagged as an error. Instead the unknown
2457option(s) will be passed to the catchall C<< <> >> if present, otherwise
2458through to C<@ARGV>. This makes it possible to write wrapper scripts that
2459process only part of the user supplied command line arguments, and pass the
2460remaining options to some other program.
2461
2462If C<require_order> is enabled, options processing will terminate at the
2463first unrecognized option, or non-option, whichever comes first and all
2464remaining arguments are passed to C<@ARGV> instead of the catchall
2465C<< <> >> if present. However, if C<permute> is enabled instead, results
2466can become confusing.
2467
2468Note that the options terminator (default C<-->), if present, will
2469also be passed through in C<@ARGV>.
2470
2471=item prefix
2472
2473The string that starts options. If a constant string is not
2474sufficient, see C<prefix_pattern>.
2475
2476=item prefix_pattern
2477
2478A Perl pattern that identifies the strings that introduce options.
2479Default is C<--|-|\+> unless environment variable
2480POSIXLY_CORRECT has been set, in which case it is C<--|->.
2481
2482=item long_prefix_pattern
2483
2484A Perl pattern that allows the disambiguation of long and short
2485prefixes. Default is C<-->.
2486
2487Typically you only need to set this if you are using nonstandard
2488prefixes and want some or all of them to have the same semantics as
2489'--' does under normal circumstances.
2490
2491For example, setting prefix_pattern to C<--|-|\+|\/> and
2492long_prefix_pattern to C<--|\/> would add Win32 style argument
2493handling.
2494
2495=item debug (default: disabled)
2496
2497Enable debugging output.
2498
2499=back
2500
2501=head1 Exportable Methods
2502
2503=over
2504
2505=item VersionMessage
2506
2507This subroutine provides a standard version message. Its argument can be:
2508
2509=over 4
2510
2511=item *
2512
2513A string containing the text of a message to print I<before> printing
2514the standard message.
2515
2516=item *
2517
2518A numeric value corresponding to the desired exit status.
2519
2520=item *
2521
2522A reference to a hash.
2523
2524=back
2525
2526If more than one argument is given then the entire argument list is
2527assumed to be a hash. If a hash is supplied (either as a reference or
2528as a list) it should contain one or more elements with the following
2529keys:
2530
2531=over 4
2532
2533=item C<-message>
2534
2535=item C<-msg>
2536
2537The text of a message to print immediately prior to printing the
2538program's usage message.
2539
2540=item C<-exitval>
2541
2542The desired exit status to pass to the B<exit()> function.
2543This should be an integer, or else the string "NOEXIT" to
2544indicate that control should simply be returned without
2545terminating the invoking process.
2546
2547=item C<-output>
2548
2549A reference to a filehandle, or the pathname of a file to which the
2550usage message should be written. The default is C<\*STDERR> unless the
2551exit value is less than 2 (in which case the default is C<\*STDOUT>).
2552
2553=back
2554
2555You cannot tie this routine directly to an option, e.g.:
2556
2557 GetOptions("version" => \&VersionMessage);
2558
2559Use this instead:
2560
2561 GetOptions("version" => sub { VersionMessage() });
2562
2563=item HelpMessage
2564
2565This subroutine produces a standard help message, derived from the
2566program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
2567arguments as VersionMessage(). In particular, you cannot tie it
2568directly to an option, e.g.:
2569
2570 GetOptions("help" => \&HelpMessage);
2571
2572Use this instead:
2573
2574 GetOptions("help" => sub { HelpMessage() });
2575
2576=back
2577
2578=head1 Return values and Errors
2579
2580Configuration errors and errors in the option definitions are
2581signalled using die() and will terminate the calling program unless
2582the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
2583}>, or die() was trapped using C<$SIG{__DIE__}>.
2584
2585GetOptions returns true to indicate success.
2586It returns false when the function detected one or more errors during
2587option parsing. These errors are signalled using warn() and can be
2588trapped with C<$SIG{__WARN__}>.
2589
2590=head1 Legacy
2591
2592The earliest development of C<newgetopt.pl> started in 1990, with Perl
2593version 4. As a result, its development, and the development of
2594Getopt::Long, has gone through several stages. Since backward
2595compatibility has always been extremely important, the current version
2596of Getopt::Long still supports a lot of constructs that nowadays are
2597no longer necessary or otherwise unwanted. This section describes
2598briefly some of these 'features'.
2599
2600=head2 Default destinations
2601
2602When no destination is specified for an option, GetOptions will store
2603the resultant value in a global variable named C<opt_>I<XXX>, where
2604I<XXX> is the primary name of this option. When a program executes
2605under C<use strict> (recommended), these variables must be
2606pre-declared with our() or C<use vars>.
2607
2608 our $opt_length = 0;
2609 GetOptions ('length=i'); # will store in $opt_length
2610
2611To yield a usable Perl variable, characters that are not part of the
2612syntax for variables are translated to underscores. For example,
2613C<--fpp-struct-return> will set the variable
2614C<$opt_fpp_struct_return>. Note that this variable resides in the
2615namespace of the calling program, not necessarily C<main>. For
2616example:
2617
2618 GetOptions ("size=i", "sizes=i@");
2619
2620with command line "-size 10 -sizes 24 -sizes 48" will perform the
2621equivalent of the assignments
2622
2623 $opt_size = 10;
2624 @opt_sizes = (24, 48);
2625
2626=head2 Alternative option starters
2627
2628A string of alternative option starter characters may be passed as the
2629first argument (or the first argument after a leading hash reference
2630argument).
2631
2632 my $len = 0;
2633 GetOptions ('/', 'length=i' => $len);
2634
2635Now the command line may look like:
2636
2637 /length 24 -- arg
2638
2639Note that to terminate options processing still requires a double dash
2640C<-->.
2641
2642GetOptions() will not interpret a leading C<< "<>" >> as option starters
2643if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
2644option starters, use C<< "><" >>. Confusing? Well, B<using a starter
2645argument is strongly deprecated> anyway.
2646
2647=head2 Configuration variables
2648
2649Previous versions of Getopt::Long used variables for the purpose of
2650configuring. Although manipulating these variables still work, it is
2651strongly encouraged to use the C<Configure> routine that was introduced
2652in version 2.17. Besides, it is much easier.
2653
2654=head1 Tips and Techniques
2655
2656=head2 Pushing multiple values in a hash option
2657
2658Sometimes you want to combine the best of hashes and arrays. For
2659example, the command line:
2660
2661 --list add=first --list add=second --list add=third
2662
2663where each successive 'list add' option will push the value of add
2664into array ref $list->{'add'}. The result would be like
2665
2666 $list->{add} = [qw(first second third)];
2667
2668This can be accomplished with a destination routine:
2669
2670 GetOptions('list=s%' =>
2671 sub { push(@{$list{$_[1]}}, $_[2]) });
2672
2673=head1 Troubleshooting
2674
2675=head2 GetOptions does not return a false result when an option is not supplied
2676
2677That's why they're called 'options'.
2678
2679=head2 GetOptions does not split the command line correctly
2680
2681The command line is not split by GetOptions, but by the command line
2682interpreter (CLI). On Unix, this is the shell. On Windows, it is
2683COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
2684
2685It is important to know that these CLIs may behave different when the
2686command line contains special characters, in particular quotes or
2687backslashes. For example, with Unix shells you can use single quotes
2688(C<'>) and double quotes (C<">) to group words together. The following
2689alternatives are equivalent on Unix:
2690
2691 "two words"
2692 'two words'
2693 two\ words
2694
2695In case of doubt, insert the following statement in front of your Perl
2696program:
2697
2698 print STDERR (join("|",@ARGV),"\n");
2699
2700to verify how your CLI passes the arguments to the program.
2701
2702=head2 Undefined subroutine &main::GetOptions called
2703
2704Are you running Windows, and did you write
2705
2706 use GetOpt::Long;
2707
2708(note the capital 'O')?
2709
2710=head2 How do I put a "-?" option into a Getopt::Long?
2711
2712You can only obtain this using an alias, and Getopt::Long of at least
2713version 2.13.
2714
2715 use Getopt::Long;
2716 GetOptions ("help|?"); # -help and -? will both set $opt_help
2717
2718Other characters that can't appear in Perl identifiers are also supported
2719as aliases with Getopt::Long of at least version 2.39.
2720
2721As of version 2.32 Getopt::Long provides auto-help, a quick and easy way
2722to add the options --help and -? to your program, and handle them.
2723
2724See C<auto_help> in section L<Configuring Getopt::Long>.
2725
2726=head1 AUTHOR
2727
2728Johan Vromans <jvromans@squirrel.nl>
2729
2730=head1 COPYRIGHT AND DISCLAIMER
2731
2732This program is Copyright 1990,2015 by Johan Vromans.
2733This program is free software; you can redistribute it and/or
2734modify it under the terms of the Perl Artistic License or the
2735GNU General Public License as published by the Free Software
2736Foundation; either version 2 of the License, or (at your option) any
2737later version.
2738
2739This program is distributed in the hope that it will be useful,
2740but WITHOUT ANY WARRANTY; without even the implied warranty of
2741MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2742GNU General Public License for more details.
2743
2744If you do not have a copy of the GNU General Public License write to
2745the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
2746MA 02139, USA.
2747
2748=cut
2749
 
# spent 599µs within Getopt::Long::CORE:match which was called 129 times, avg 5µs/call: # 39 times (120µs+0s) by Getopt::Long::GetOptionsFromArray at line 363, avg 3µs/call # 38 times (218µs+0s) by Getopt::Long::ParseOptionSpec at line 803, avg 6µs/call # 15 times (81µs+0s) by Getopt::Long::ParseOptionSpec at line 865, avg 5µs/call # 15 times (40µs+0s) by Getopt::Long::ParseOptionSpec at line 849, avg 3µs/call # 6 times (15µs+0s) by Getopt::Long::Configure at line 1339, avg 3µs/call # 5 times (46µs+0s) by Getopt::Long::Configure at line 1335, avg 9µs/call # 4 times (18µs+0s) by Getopt::Long::FindOption at line 934, avg 4µs/call # 2 times (7µs+0s) by Getopt::Long::FindOption at line 947, avg 3µs/call # 2 times (6µs+0s) by Getopt::Long::GetOptionsFromArray at line 743, avg 3µs/call # once (39µs+0s) by main::BEGIN@24 at line 128 # once (5µs+0s) by Getopt::Long::GetOptionsFromArray at line 341 # once (2µs+0s) by Getopt::Long::GetOptionsFromArray at line 620
sub Getopt::Long::CORE:match; # opcode
# spent 263µs within Getopt::Long::CORE:regcomp which was called 45 times, avg 6µs/call: # 39 times (193µs+0s) by Getopt::Long::GetOptionsFromArray at line 363, avg 5µs/call # 4 times (53µs+0s) by Getopt::Long::FindOption at line 934, avg 13µs/call # 2 times (16µs+0s) by Getopt::Long::FindOption at line 947, avg 8µs/call
sub Getopt::Long::CORE:regcomp; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.