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