← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:10 2016

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