Profile of Getopt/Long.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For bin/dpath
Run on Tue Jun 5 15:30:18 2012
Reported on Tue Jun 5 15:30:37 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Getopt/Long.pm
Statements | Executed 466 statements in 39.6ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
7 | 1 | 1 | 628µs | 758µs | Getopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
1 | 1 | 1 | 399µs | 1.40ms | Getopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
5 | 5 | 1 | 309µs | 316µs | Getopt::Long::::Configure Getopt::Long::Configure
30 | 9 | 1 | 234µs | 234µs | Getopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
8 | 2 | 1 | 149µs | 149µs | Getopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
1 | 1 | 1 | 131µs | 251µs | Getopt::Long::::BEGIN@220 Getopt::Long::BEGIN@220
1 | 1 | 1 | 101µs | 1.58ms | Getopt::Long::Parser::::getoptions Getopt::Long::Parser::getoptions
1 | 1 | 1 | 97µs | 97µs | Getopt::Long::::BEGIN@15 Getopt::Long::BEGIN@15
1 | 1 | 1 | 62µs | 164µs | Getopt::Long::::BEGIN@19 Getopt::Long::BEGIN@19
1 | 1 | 1 | 61µs | 61µs | Getopt::Long::Parser::::new Getopt::Long::Parser::new
1 | 1 | 1 | 55µs | 272µs | Getopt::Long::CallBack::::BEGIN@1489Getopt::Long::CallBack::BEGIN@1489
1 | 1 | 1 | 45µs | 223µs | Getopt::Long::::BEGIN@208 Getopt::Long::BEGIN@208
1 | 1 | 1 | 38µs | 258µs | Getopt::Long::Parser::::configure Getopt::Long::Parser::configure
1 | 1 | 1 | 36µs | 130µs | Getopt::Long::::BEGIN@25 Getopt::Long::BEGIN@25
1 | 1 | 1 | 34µs | 84µs | Getopt::Long::::FindOption Getopt::Long::FindOption
1 | 1 | 1 | 33µs | 230µs | Getopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1 | 1 | 1 | 30µs | 30µs | Getopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
1 | 1 | 1 | 30µs | 47µs | Getopt::Long::::BEGIN@17 Getopt::Long::BEGIN@17
1 | 1 | 1 | 28µs | 144µs | Getopt::Long::::BEGIN@247 Getopt::Long::BEGIN@247
1 | 1 | 1 | 27µs | 130µs | Getopt::Long::::BEGIN@225 Getopt::Long::BEGIN@225
1 | 1 | 1 | 26µs | 131µs | Getopt::Long::::BEGIN@237 Getopt::Long::BEGIN@237
1 | 1 | 1 | 26µs | 356µs | Getopt::Long::::BEGIN@48 Getopt::Long::BEGIN@48
1 | 1 | 1 | 25µs | 300µs | Getopt::Long::::BEGIN@51 Getopt::Long::BEGIN@51
1 | 1 | 1 | 25µs | 135µs | Getopt::Long::::BEGIN@218 Getopt::Long::BEGIN@218
1 | 1 | 1 | 25µs | 137µs | Getopt::Long::::BEGIN@229 Getopt::Long::BEGIN@229
1 | 1 | 1 | 25µs | 534µs | Getopt::Long::::BEGIN@45 Getopt::Long::BEGIN@45
1 | 1 | 1 | 25µs | 148µs | Getopt::Long::::BEGIN@222 Getopt::Long::BEGIN@222
1 | 1 | 1 | 25µs | 128µs | Getopt::Long::::BEGIN@226 Getopt::Long::BEGIN@226
1 | 1 | 1 | 25µs | 190µs | Getopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1 | 1 | 1 | 25µs | 128µs | Getopt::Long::::BEGIN@228 Getopt::Long::BEGIN@228
1 | 1 | 1 | 24µs | 128µs | Getopt::Long::::BEGIN@223 Getopt::Long::BEGIN@223
1 | 1 | 1 | 24µs | 129µs | Getopt::Long::::BEGIN@224 Getopt::Long::BEGIN@224
1 | 1 | 1 | 24µs | 129µs | Getopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1 | 1 | 1 | 21µs | 21µs | Getopt::Long::::BEGIN@37 Getopt::Long::BEGIN@37
1 | 1 | 1 | 20µs | 20µs | Getopt::Long::::GetOptions Getopt::Long::GetOptions
0 | 0 | 0 | 0s | 0s | Getopt::Long::CallBack::::nameGetopt::Long::CallBack::name
0 | 0 | 0 | 0s | 0s | Getopt::Long::CallBack::::newGetopt::Long::CallBack::new
0 | 0 | 0 | 0s | 0s | Getopt::Long::::GetOptionsFromString Getopt::Long::GetOptionsFromString
0 | 0 | 0 | 0s | 0s | Getopt::Long::::HelpMessage Getopt::Long::HelpMessage
0 | 0 | 0 | 0s | 0s | Getopt::Long::::OptCtl Getopt::Long::OptCtl
0 | 0 | 0 | 0s | 0s | Getopt::Long::::VERSION Getopt::Long::VERSION
0 | 0 | 0 | 0s | 0s | Getopt::Long::::ValidValue Getopt::Long::ValidValue
0 | 0 | 0 | 0s | 0s | Getopt::Long::::VersionMessage Getopt::Long::VersionMessage
0 | 0 | 0 | 0s | 0s | Getopt::Long::::config Getopt::Long::config
0 | 0 | 0 | 0s | 0s | Getopt::Long::::import Getopt::Long::import
0 | 0 | 0 | 0s | 0s | Getopt::Long::::setup_pa_args Getopt::Long::setup_pa_args

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | # Getopt::Long.pm -- Universal options parsing
2 |  |  |  |  |
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 | 198µs | 1 | 97µs | # spent 97µs within Getopt::Long::BEGIN@15 which was called: # once (97µs+0s) by App::Rad::getopt at line 15 use 5.004; # spent 97µs making 1 call to Getopt::Long::BEGIN@15
16 |  |  |  |  |
17 | 2 | 104µs | 2 | 64µs | # spent 47µs (30+17) within Getopt::Long::BEGIN@17 which was called: # once (30µs+17µs) by App::Rad::getopt at line 17 use strict; # spent 47µs making 1 call to Getopt::Long::BEGIN@17 # spent 17µs making 1 call to strict::import
18 |  |  |  |  |
19 | 2 | 180µs | 2 | 266µs | # spent 164µs (62+102) within Getopt::Long::BEGIN@19 which was called: # once (62µs+102µs) by App::Rad::getopt at line 19 use vars qw($VERSION); # spent 164µs making 1 call to Getopt::Long::BEGIN@19 # spent 102µs making 1 call to vars::import
20 | 1 | 3µs |  |  | $VERSION = 2.38;
21 |  |  |  |  | # For testing versions only.
22 |  |  |  |  | #use vars qw($VERSION_STRING);
23 |  |  |  |  | #$VERSION_STRING = "2.38";
24 |  |  |  |  |
25 | 2 | 109µs | 2 | 225µs | # spent 130µs (36+94) within Getopt::Long::BEGIN@25 which was called: # once (36µs+94µs) by App::Rad::getopt at line 25 use Exporter; # spent 130µs making 1 call to Getopt::Long::BEGIN@25 # spent 94µs making 1 call to Exporter::import
26 | 2 | 324µs | 2 | 355µs | # spent 190µs (25+165) within Getopt::Long::BEGIN@26 which was called: # once (25µs+165µs) by App::Rad::getopt at line 26 use vars qw(@ISA @EXPORT @EXPORT_OK); # spent 190µs making 1 call to Getopt::Long::BEGIN@26 # spent 165µs making 1 call to vars::import
27 | 1 | 41µ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 21µs within Getopt::Long::BEGIN@37 which was called: # once (21µs+0s) by App::Rad::getopt at line 42 BEGIN {
38 |  |  |  |  | # Init immediately so their contents can be used in the 'use vars' below.
39 | 2 | 23µs |  |  | @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
40 |  |  |  |  | @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
41 |  |  |  |  | &GetOptionsFromArray &GetOptionsFromString);
42 | 1 | 95µs | 1 | 21µs | } # spent 21µs making 1 call to Getopt::Long::BEGIN@37
43 |  |  |  |  |
44 |  |  |  |  | # User visible variables.
45 | 2 | 101µs | 2 | 1.04ms | # spent 534µs (25+509) within Getopt::Long::BEGIN@45 which was called: # once (25µs+509µs) by App::Rad::getopt at line 45 use vars @EXPORT, @EXPORT_OK; # spent 534µs making 1 call to Getopt::Long::BEGIN@45 # spent 509µs making 1 call to vars::import
46 | 2 | 140µs | 2 | 427µs | # spent 230µs (33+197) within Getopt::Long::BEGIN@46 which was called: # once (33µs+197µs) by App::Rad::getopt at line 46 use vars qw($error $debug $major_version $minor_version); # spent 230µs making 1 call to Getopt::Long::BEGIN@46 # spent 197µs making 1 call to vars::import
47 |  |  |  |  | # Deprecated visible variables.
48 |  |  | 1 | 330µs | # spent 356µs (26+330) within Getopt::Long::BEGIN@48 which was called: # once (26µs+330µs) by App::Rad::getopt at line 49 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order # spent 330µs making 1 call to vars::import
49 | 2 | 112µs | 1 | 356µs | $passthrough); # spent 356µs making 1 call to Getopt::Long::BEGIN@48
50 |  |  |  |  | # Official invisible variables.
51 | 2 | 2.61ms | 2 | 575µs | # spent 300µs (25+275) within Getopt::Long::BEGIN@51 which was called: # once (25µs+275µs) by App::Rad::getopt at line 51 use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); # spent 300µs making 1 call to Getopt::Long::BEGIN@51 # spent 275µ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 | 2µs |  |  | my $requested_version = 0;
69 |  |  |  |  |
70 |  |  |  |  | ################ Resident subroutines ################
71 |  |  |  |  |
72 |  |  |  |  | # spent 30µs within Getopt::Long::ConfigDefaults which was called: # once (30µs+0s) by App::Rad::getopt at line 125 sub ConfigDefaults() {
73 |  |  |  |  | # Handle POSIX compliancy.
74 | 12 | 35µs |  |  | if ( defined $ENV{"POSIXLY_CORRECT"} ) {
75 |  |  |  |  | $genprefix = "(--|-)";
76 |  |  |  |  | $autoabbrev = 0; # no automatic abbrev of options
77 |  |  |  |  | $bundling = 0; # no bundling of single letter switches
78 |  |  |  |  | $getopt_compat = 0; # disallow '+' to start options
79 |  |  |  |  | $order = $REQUIRE_ORDER;
80 |  |  |  |  | }
81 |  |  |  |  | else {
82 |  |  |  |  | $genprefix = "(--|-|\\+)";
83 |  |  |  |  | $autoabbrev = 1; # automatic abbrev of options
84 |  |  |  |  | $bundling = 0; # bundling off by default
85 |  |  |  |  | $getopt_compat = 1; # allow '+' to start options
86 |  |  |  |  | $order = $PERMUTE;
87 |  |  |  |  | }
88 |  |  |  |  | # Other configurable settings.
89 |  |  |  |  | $debug = 0; # for debugging
90 |  |  |  |  | $error = 0; # error tally
91 |  |  |  |  | $ignorecase = 1; # ignore case when matching options
92 |  |  |  |  | $passthrough = 0; # leave unrecognized options alone
93 |  |  |  |  | $gnu_compat = 0; # require --opt=val if value is optional
94 |  |  |  |  | $longprefix = "(--)"; # what does a long prefix look like
95 |  |  |  |  | }
96 |  |  |  |  |
97 |  |  |  |  | # Override import.
98 |  |  |  |  | sub import {
99 |  |  |  |  | my $pkg = shift; # package
100 |  |  |  |  | my @syms = (); # symbols to import
101 |  |  |  |  | my @config = (); # configuration
102 |  |  |  |  | my $dest = \@syms; # symbols first
103 |  |  |  |  | for ( @_ ) {
104 |  |  |  |  | if ( $_ eq ':config' ) {
105 |  |  |  |  | $dest = \@config; # config next
106 |  |  |  |  | next;
107 |  |  |  |  | }
108 |  |  |  |  | push(@$dest, $_); # push
109 |  |  |  |  | }
110 |  |  |  |  | # Hide one level and call super.
111 |  |  |  |  | local $Exporter::ExportLevel = 1;
112 |  |  |  |  | push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
113 |  |  |  |  | $pkg->SUPER::import(@syms);
114 |  |  |  |  | # And configure.
115 |  |  |  |  | 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 | 77µs | 1 | 45µs | ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; # spent 45µs making 1 call to Getopt::Long::CORE:match
124 |  |  |  |  |
125 | 1 | 10µs | 1 | 30µs | ConfigDefaults(); # spent 30µ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 | 8µs | 1 | 33µs | my $default_config = do { # spent 33µs making 1 call to Getopt::Long::Configure
134 |  |  |  |  | Getopt::Long::Configure ()
135 |  |  |  |  | };
136 |  |  |  |  |
137 |  |  |  |  | # spent 61µs within Getopt::Long::Parser::new which was called: # once (61µs+0s) by App::Rad::getopt at line 450 of App/Rad.pm sub new {
138 | 8 | 68µs |  |  | 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 | 1 | 3µs |  |  | 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 |  |  |  |  | # spent 258µs (38+220) within Getopt::Long::Parser::configure which was called: # once (38µs+220µs) by App::Rad::getopt at line 451 of App/Rad.pm sub configure {
167 | 3 | 30µs |  |  | my ($self) = shift;
168 |  |  |  |  |
169 |  |  |  |  | # Restore settings, merge new settings in.
170 |  |  | 1 | 89µs | my $save = Getopt::Long::Configure ($self->{settings}, @_); # spent 89µs making 1 call to Getopt::Long::Configure
171 |  |  |  |  |
172 |  |  |  |  | # Restore orig config and save the new config.
173 |  |  | 1 | 131µs | $self->{settings} = Getopt::Long::Configure ($save); # spent 131µs making 1 call to Getopt::Long::Configure
174 |  |  |  |  | }
175 |  |  |  |  |
176 |  |  |  |  | # spent 1.58ms (101µs+1.48) within Getopt::Long::Parser::getoptions which was called: # once (101µs+1.48ms) by App::Rad::getopt at line 454 of App/Rad.pm sub getoptions {
177 | 8 | 38µs |  |  | my ($self) = shift;
178 |  |  |  |  |
179 |  |  |  |  | # Restore config settings.
180 |  |  | 1 | 28µs | my $save = Getopt::Long::Configure ($self->{settings}); # spent 28µs making 1 call to Getopt::Long::Configure
181 |  |  |  |  |
182 |  |  |  |  | # Call main routine.
183 |  |  |  |  | my $ret = 0;
184 |  |  |  |  | $Getopt::Long::caller = $self->{caller_pkg};
185 |  |  |  |  |
186 | 2 | 30µs |  |  | 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 |  |  | 1 | 20µs | $ret = Getopt::Long::GetOptions (@_); # spent 20µs making 1 call to Getopt::Long::GetOptions
192 |  |  |  |  | };
193 |  |  |  |  |
194 |  |  |  |  | # Restore saved settings.
195 |  |  | 1 | 35µs | Getopt::Long::Configure ($save); # spent 35µs making 1 call to Getopt::Long::Configure
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 | 140µs | 2 | 401µs | # spent 223µs (45+178) within Getopt::Long::BEGIN@208 which was called: # once (45µs+178µs) by App::Rad::getopt at line 208 use constant CTL_TYPE => 0; # spent 223µs making 1 call to Getopt::Long::BEGIN@208 # spent 178µ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 | 203µs | 2 | 244µs | # spent 135µs (25+109) within Getopt::Long::BEGIN@218 which was called: # once (25µs+109µs) by App::Rad::getopt at line 218 use constant CTL_CNAME => 1; # spent 135µs making 1 call to Getopt::Long::BEGIN@218 # spent 109µs making 1 call to constant::import
219 |  |  |  |  |
220 | 2 | 104µs | 2 | 371µs | # spent 251µs (131+120) within Getopt::Long::BEGIN@220 which was called: # once (131µs+120µs) by App::Rad::getopt at line 220 use constant CTL_DEFAULT => 2; # spent 251µs making 1 call to Getopt::Long::BEGIN@220 # spent 120µs making 1 call to constant::import
221 |  |  |  |  |
222 | 2 | 94µs | 2 | 271µs | # spent 148µs (25+123) within Getopt::Long::BEGIN@222 which was called: # once (25µs+123µs) by App::Rad::getopt at line 222 use constant CTL_DEST => 3; # spent 148µs making 1 call to Getopt::Long::BEGIN@222 # spent 123µs making 1 call to constant::import
223 | 2 | 110µs | 2 | 233µs | # spent 128µs (24+104) within Getopt::Long::BEGIN@223 which was called: # once (24µs+104µs) by App::Rad::getopt at line 223 use constant CTL_DEST_SCALAR => 0; # spent 128µs making 1 call to Getopt::Long::BEGIN@223 # spent 104µs making 1 call to constant::import
224 | 2 | 94µs | 2 | 233µs | # spent 129µs (24+105) within Getopt::Long::BEGIN@224 which was called: # once (24µs+105µs) by App::Rad::getopt at line 224 use constant CTL_DEST_ARRAY => 1; # spent 129µs making 1 call to Getopt::Long::BEGIN@224 # spent 105µs making 1 call to constant::import
225 | 2 | 92µs | 2 | 234µs | # spent 130µs (27+104) within Getopt::Long::BEGIN@225 which was called: # once (27µs+104µs) by App::Rad::getopt at line 225 use constant CTL_DEST_HASH => 2; # spent 130µs making 1 call to Getopt::Long::BEGIN@225 # spent 104µs making 1 call to constant::import
226 | 2 | 96µs | 2 | 231µs | # spent 128µs (25+103) within Getopt::Long::BEGIN@226 which was called: # once (25µs+103µs) by App::Rad::getopt at line 226 use constant CTL_DEST_CODE => 3; # spent 128µs making 1 call to Getopt::Long::BEGIN@226 # spent 103µs making 1 call to constant::import
227 |  |  |  |  |
228 | 2 | 105µs | 2 | 232µs | # spent 128µs (25+104) within Getopt::Long::BEGIN@228 which was called: # once (25µs+104µs) by App::Rad::getopt at line 228 use constant CTL_AMIN => 4; # spent 128µs making 1 call to Getopt::Long::BEGIN@228 # spent 104µs making 1 call to constant::import
229 | 2 | 113µs | 2 | 249µs | # spent 137µs (25+112) within Getopt::Long::BEGIN@229 which was called: # once (25µs+112µs) by App::Rad::getopt at line 229 use constant CTL_AMAX => 5; # spent 137µs making 1 call to Getopt::Long::BEGIN@229 # spent 112µ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 | 218µs | 2 | 234µs | # spent 129µs (24+105) within Getopt::Long::BEGIN@236 which was called: # once (24µs+105µs) by App::Rad::getopt at line 236 use constant PAT_INT => "[-+]?_*[0-9][0-9_]*"; # spent 129µs making 1 call to Getopt::Long::BEGIN@236 # spent 105µs making 1 call to constant::import
237 |  |  | 1 | 105µs | # spent 131µs (26+105) within Getopt::Long::BEGIN@237 which was called: # once (26µs+105µs) by App::Rad::getopt at line 246 use constant PAT_XINT => # spent 105µ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 | 2 | 128µs | 1 | 131µs | ")"; # spent 131µs making 1 call to Getopt::Long::BEGIN@237
247 | 2 | 28.8ms | 2 | 261µs | # spent 144µs (28+116) within Getopt::Long::BEGIN@247 which was called: # once (28µs+116µs) by App::Rad::getopt at line 247 use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?"; # spent 144µs making 1 call to Getopt::Long::BEGIN@247 # spent 116µs making 1 call to constant::import
248 |  |  |  |  |
249 |  |  |  |  | # spent 20µs within Getopt::Long::GetOptions which was called: # once (20µs+0s) by Getopt::Long::Parser::getoptions at line 191 sub GetOptions(@) {
250 |  |  |  |  | # Shift in default array.
251 | 2 | 35µs |  |  | unshift(@_, \@ARGV);
252 |  |  |  |  | # Try to keep caller() and Carp consitent.
253 |  |  | 1 | 1.40ms | goto &GetOptionsFromArray; # spent 1.40ms 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 1.40ms (399µs+999µs) within Getopt::Long::GetOptionsFromArray which was called: # once (399µs+999µs) by Getopt::Long::Parser::getoptions at line 253 sub GetOptionsFromArray(@) {
271 |  |  |  |  |
272 | 25 | 123µs |  |  | my ($argv, @optionlist) = @_; # local copy of the option descriptions
273 |  |  |  |  | my $argend = '--'; # option list terminator
274 |  |  |  |  | my %opctl = (); # table of option specs
275 |  |  |  |  | my $pkg = $caller || (caller)[0]; # current context
276 |  |  |  |  | # Needed if linkage is omitted.
277 |  |  |  |  | my @ret = (); # accum for non-options
278 |  |  |  |  | my %linkage; # linkage
279 |  |  |  |  | my $userlinkage; # user supplied HASH
280 |  |  |  |  | my $opt; # current option
281 |  |  |  |  | my $prefix = $genprefix; # current prefix
282 |  |  |  |  |
283 |  |  |  |  | $error = '';
284 |  |  |  |  |
285 |  |  |  |  | if ( $debug ) {
286 |  |  |  |  | # Avoid some warnings if debugging.
287 |  |  |  |  | local ($^W) = 0;
288 |  |  |  |  | print STDERR
289 |  |  |  |  | ("Getopt::Long $Getopt::Long::VERSION (",
290 |  |  |  |  | '$Revision: 2.76 $', ") ",
291 |  |  |  |  | "called from package \"$pkg\".",
292 |  |  |  |  | "\n ",
293 |  |  |  |  | "argv: (@$argv)",
294 |  |  |  |  | "\n ",
295 |  |  |  |  | "autoabbrev=$autoabbrev,".
296 |  |  |  |  | "bundling=$bundling,",
297 |  |  |  |  | "getopt_compat=$getopt_compat,",
298 |  |  |  |  | "gnu_compat=$gnu_compat,",
299 |  |  |  |  | "order=$order,",
300 |  |  |  |  | "\n ",
301 |  |  |  |  | "ignorecase=$ignorecase,",
302 |  |  |  |  | "requested_version=$requested_version,",
303 |  |  |  |  | "passthrough=$passthrough,",
304 |  |  |  |  | "genprefix=\"$genprefix\",",
305 |  |  |  |  | "longprefix=\"$longprefix\".",
306 |  |  |  |  | "\n");
307 |  |  |  |  | }
308 |  |  |  |  |
309 |  |  |  |  | # Check for ref HASH as first argument.
310 |  |  |  |  | # First argument may be an object. It's OK to use this as long
311 |  |  |  |  | # as it is really a hash underneath.
312 |  |  |  |  | $userlinkage = undef;
313 | 2 | 3µs | 1 | 5µs | if ( @optionlist && ref($optionlist[0]) and # spent 5µs making 1 call to UNIVERSAL::isa
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 | 9µs | if ( @optionlist && $optionlist[0] =~ /^\W+$/ # spent 9µs making 1 call to Getopt::Long::CORE:match
323 |  |  |  |  | && !($optionlist[0] eq '<>'
324 |  |  |  |  | && @optionlist > 0
325 |  |  |  |  | && ref($optionlist[1])) ) {
326 |  |  |  |  | $prefix = shift (@optionlist);
327 |  |  |  |  | # Turn into regexp. Needs to be parenthesized!
328 |  |  |  |  | $prefix =~ s/(\W)/\\$1/g;
329 |  |  |  |  | $prefix = "([" . $prefix . "])";
330 |  |  |  |  | print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
331 |  |  |  |  | }
332 |  |  |  |  |
333 |  |  |  |  | # Verify correctness of optionlist.
334 |  |  |  |  | %opctl = ();
335 |  |  |  |  | while ( @optionlist ) {
336 | 49 | 338µs |  |  | my $opt = shift (@optionlist);
337 |  |  |  |  |
338 |  |  |  |  | unless ( defined($opt) ) {
339 |  |  |  |  | $error .= "Undefined argument in option spec\n";
340 |  |  |  |  | next;
341 |  |  |  |  | }
342 |  |  |  |  |
343 |  |  |  |  | # Strip leading prefix so people can specify "--foo=i" if they like.
344 |  |  | 14 | 142µs | $opt = $+ if $opt =~ /^$prefix+(.*)$/s; # spent 104µs making 7 calls to Getopt::Long::CORE:regcomp, avg 15µs/call # spent 39µs making 7 calls to Getopt::Long::CORE:match, avg 6µs/call
345 |  |  |  |  |
346 |  |  |  |  | if ( $opt eq '<>' ) {
347 |  |  |  |  | if ( (defined $userlinkage)
348 |  |  |  |  | && !(@optionlist > 0 && ref($optionlist[0]))
349 |  |  |  |  | && (exists $userlinkage->{$opt})
350 |  |  |  |  | && ref($userlinkage->{$opt}) ) {
351 |  |  |  |  | unshift (@optionlist, $userlinkage->{$opt});
352 |  |  |  |  | }
353 |  |  |  |  | unless ( @optionlist > 0
354 |  |  |  |  | && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
355 |  |  |  |  | $error .= "Option spec <> requires a reference to a subroutine\n";
356 |  |  |  |  | # Kill the linkage (to avoid another error).
357 |  |  |  |  | shift (@optionlist)
358 |  |  |  |  | if @optionlist && ref($optionlist[0]);
359 |  |  |  |  | next;
360 |  |  |  |  | }
361 |  |  |  |  | $linkage{'<>'} = shift (@optionlist);
362 |  |  |  |  | next;
363 |  |  |  |  | }
364 |  |  |  |  |
365 |  |  |  |  | # Parse option spec.
366 |  |  | 7 | 758µs | my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); # spent 758µs making 7 calls to Getopt::Long::ParseOptionSpec, avg 108µs/call
367 |  |  |  |  | unless ( defined $name ) {
368 |  |  |  |  | # Failed. $orig contains the error message. Sorry for the abuse.
369 |  |  |  |  | $error .= $orig;
370 |  |  |  |  | # Kill the linkage (to avoid another error).
371 |  |  |  |  | shift (@optionlist)
372 |  |  |  |  | if @optionlist && ref($optionlist[0]);
373 |  |  |  |  | next;
374 |  |  |  |  | }
375 |  |  |  |  |
376 |  |  |  |  | # If no linkage is supplied in the @optionlist, copy it from
377 |  |  |  |  | # the userlinkage if available.
378 | 7 | 12µs |  |  | if ( defined $userlinkage ) {
379 | 7 | 8µs |  |  | unless ( @optionlist > 0 && ref($optionlist[0]) ) {
380 | 7 | 16µs |  |  | 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 |  |  |  |  | if ( @optionlist > 0 && ref($optionlist[0]) ) {
396 |  |  |  |  | print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
397 |  |  |  |  | if $debug;
398 |  |  |  |  | my $rl = ref($linkage{$orig} = shift (@optionlist));
399 |  |  |  |  |
400 |  |  |  |  | if ( $rl eq "ARRAY" ) {
401 |  |  |  |  | $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
402 |  |  |  |  | }
403 |  |  |  |  | elsif ( $rl eq "HASH" ) {
404 |  |  |  |  | $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
405 |  |  |  |  | }
406 |  |  |  |  | elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
407 |  |  |  |  | # if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
408 |  |  |  |  | # my $t = $linkage{$orig};
409 |  |  |  |  | # $$t = $linkage{$orig} = [];
410 |  |  |  |  | # }
411 |  |  |  |  | # elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
412 |  |  |  |  | # }
413 |  |  |  |  | # else {
414 |  |  |  |  | # Ok.
415 |  |  |  |  | # }
416 |  |  |  |  | }
417 |  |  |  |  | elsif ( $rl eq "CODE" ) {
418 |  |  |  |  | # Ok.
419 |  |  |  |  | }
420 |  |  |  |  | else {
421 |  |  |  |  | $error .= "Invalid option linkage for \"$opt\"\n";
422 |  |  |  |  | }
423 |  |  |  |  | }
424 |  |  |  |  | else {
425 |  |  |  |  | # Link to global $opt_XXX variable.
426 |  |  |  |  | # Make sure a valid perl identifier results.
427 |  |  |  |  | my $ov = $orig;
428 |  |  |  |  | $ov =~ s/\W/_/g;
429 |  |  |  |  | if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
430 |  |  |  |  | print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
431 |  |  |  |  | if $debug;
432 |  |  |  |  | eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
433 |  |  |  |  | }
434 |  |  |  |  | elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
435 |  |  |  |  | print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
436 |  |  |  |  | if $debug;
437 |  |  |  |  | eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
438 |  |  |  |  | }
439 |  |  |  |  | else {
440 |  |  |  |  | print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
441 |  |  |  |  | if $debug;
442 |  |  |  |  | eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
443 |  |  |  |  | }
444 |  |  |  |  | }
445 |  |  |  |  |
446 |  |  |  |  | if ( $opctl{$name}[CTL_TYPE] eq 'I'
447 |  |  |  |  | && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
448 |  |  |  |  | || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
449 |  |  |  |  | ) {
450 |  |  |  |  | $error .= "Invalid option linkage for \"$opt\"\n";
451 |  |  |  |  | }
452 |  |  |  |  |
453 |  |  |  |  | }
454 |  |  |  |  |
455 |  |  |  |  | # Bail out if errors found.
456 |  |  |  |  | die ($error) if $error;
457 |  |  |  |  | $error = 0;
458 |  |  |  |  |
459 |  |  |  |  | # Supply --version and --help support, if needed and allowed.
460 |  |  |  |  | if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
461 |  |  |  |  | if ( !defined($opctl{version}) ) {
462 |  |  |  |  | $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
463 |  |  |  |  | $linkage{version} = \&VersionMessage;
464 |  |  |  |  | }
465 |  |  |  |  | $auto_version = 1;
466 |  |  |  |  | }
467 |  |  |  |  | if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
468 |  |  |  |  | if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
469 |  |  |  |  | $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
470 |  |  |  |  | $linkage{help} = \&HelpMessage;
471 |  |  |  |  | }
472 |  |  |  |  | $auto_help = 1;
473 |  |  |  |  | }
474 |  |  |  |  |
475 |  |  |  |  | # Show the options tables if debugging.
476 |  |  |  |  | if ( $debug ) {
477 |  |  |  |  | my ($arrow, $k, $v);
478 |  |  |  |  | $arrow = "=> ";
479 |  |  |  |  | while ( ($k,$v) = each(%opctl) ) {
480 |  |  |  |  | print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
481 |  |  |  |  | $arrow = " ";
482 |  |  |  |  | }
483 |  |  |  |  | }
484 |  |  |  |  |
485 |  |  |  |  | # Process argument list
486 |  |  |  |  | my $goon = 1;
487 |  |  |  |  | while ( $goon && @$argv > 0 ) {
488 |  |  |  |  |
489 |  |  |  |  | # Get next argument.
490 | 10 | 25µs |  |  | $opt = shift (@$argv);
491 |  |  |  |  | print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
492 |  |  |  |  |
493 |  |  |  |  | # Double dash is option list terminator.
494 |  |  |  |  | if ( $opt eq $argend ) {
495 |  |  |  |  | push (@ret, $argend) if $passthrough;
496 |  |  |  |  | last;
497 |  |  |  |  | }
498 |  |  |  |  |
499 |  |  |  |  | # Look it up.
500 |  |  |  |  | my $tryopt = $opt;
501 |  |  |  |  | my $found; # success status
502 |  |  |  |  | my $key; # key (if hash type)
503 |  |  |  |  | my $arg; # option argument
504 |  |  |  |  | my $ctl; # the opctl entry
505 |  |  |  |  |
506 |  |  | 1 | 84µs | ($found, $opt, $ctl, $arg, $key) = # spent 84µs making 1 call to Getopt::Long::FindOption
507 |  |  |  |  | FindOption ($argv, $prefix, $argend, $opt, \%opctl);
508 |  |  |  |  |
509 | 3 | 5µs |  |  | if ( $found ) {
510 |  |  |  |  |
511 |  |  |  |  | # FindOption undefines $opt in case of errors.
512 |  |  |  |  | next unless defined $opt;
513 |  |  |  |  |
514 |  |  |  |  | my $argcnt = 0;
515 |  |  |  |  | while ( defined $arg ) {
516 |  |  |  |  |
517 |  |  |  |  | # Get the canonical name.
518 |  |  |  |  | print STDERR ("=> cname for \"$opt\" is ") if $debug;
519 |  |  |  |  | $opt = $ctl->[CTL_CNAME];
520 |  |  |  |  | print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
521 |  |  |  |  |
522 |  |  |  |  | if ( defined $linkage{$opt} ) {
523 |  |  |  |  | print STDERR ("=> ref(\$L{$opt}) -> ",
524 |  |  |  |  | ref($linkage{$opt}), "\n") if $debug;
525 |  |  |  |  |
526 |  |  |  |  | if ( ref($linkage{$opt}) eq 'SCALAR'
527 |  |  |  |  | || ref($linkage{$opt}) eq 'REF' ) {
528 |  |  |  |  | if ( $ctl->[CTL_TYPE] eq '+' ) {
529 |  |  |  |  | print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
530 |  |  |  |  | if $debug;
531 |  |  |  |  | if ( defined ${$linkage{$opt}} ) {
532 |  |  |  |  | ${$linkage{$opt}} += $arg;
533 |  |  |  |  | }
534 |  |  |  |  | else {
535 |  |  |  |  | ${$linkage{$opt}} = $arg;
536 |  |  |  |  | }
537 |  |  |  |  | }
538 |  |  |  |  | elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
539 |  |  |  |  | print STDERR ("=> ref(\$L{$opt}) auto-vivified",
540 |  |  |  |  | " to ARRAY\n")
541 |  |  |  |  | if $debug;
542 |  |  |  |  | my $t = $linkage{$opt};
543 |  |  |  |  | $$t = $linkage{$opt} = [];
544 |  |  |  |  | print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
545 |  |  |  |  | if $debug;
546 |  |  |  |  | push (@{$linkage{$opt}}, $arg);
547 |  |  |  |  | }
548 |  |  |  |  | elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
549 |  |  |  |  | print STDERR ("=> ref(\$L{$opt}) auto-vivified",
550 |  |  |  |  | " to HASH\n")
551 |  |  |  |  | if $debug;
552 |  |  |  |  | my $t = $linkage{$opt};
553 |  |  |  |  | $$t = $linkage{$opt} = {};
554 |  |  |  |  | print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
555 |  |  |  |  | if $debug;
556 |  |  |  |  | $linkage{$opt}->{$key} = $arg;
557 |  |  |  |  | }
558 |  |  |  |  | else {
559 |  |  |  |  | print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
560 |  |  |  |  | if $debug;
561 |  |  |  |  | ${$linkage{$opt}} = $arg;
562 |  |  |  |  | }
563 |  |  |  |  | }
564 |  |  |  |  | elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
565 |  |  |  |  | print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
566 |  |  |  |  | if $debug;
567 |  |  |  |  | push (@{$linkage{$opt}}, $arg);
568 |  |  |  |  | }
569 |  |  |  |  | elsif ( ref($linkage{$opt}) eq 'HASH' ) {
570 |  |  |  |  | print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
571 |  |  |  |  | if $debug;
572 |  |  |  |  | $linkage{$opt}->{$key} = $arg;
573 |  |  |  |  | }
574 |  |  |  |  | elsif ( ref($linkage{$opt}) eq 'CODE' ) {
575 |  |  |  |  | print STDERR ("=> &L{$opt}(\"$opt\"",
576 |  |  |  |  | $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
577 |  |  |  |  | ", \"$arg\")\n")
578 |  |  |  |  | if $debug;
579 |  |  |  |  | my $eval_error = do {
580 |  |  |  |  | local $@;
581 |  |  |  |  | local $SIG{__DIE__} = 'DEFAULT';
582 |  |  |  |  | eval {
583 |  |  |  |  | &{$linkage{$opt}}
584 |  |  |  |  | (Getopt::Long::CallBack->new
585 |  |  |  |  | (name => $opt,
586 |  |  |  |  | ctl => $ctl,
587 |  |  |  |  | opctl => \%opctl,
588 |  |  |  |  | linkage => \%linkage,
589 |  |  |  |  | prefix => $prefix,
590 |  |  |  |  | ),
591 |  |  |  |  | $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
592 |  |  |  |  | $arg);
593 |  |  |  |  | };
594 |  |  |  |  | $@;
595 |  |  |  |  | };
596 |  |  |  |  | print STDERR ("=> die($eval_error)\n")
597 |  |  |  |  | if $debug && $eval_error ne '';
598 |  |  |  |  | if ( $eval_error =~ /^!/ ) {
599 |  |  |  |  | if ( $eval_error =~ /^!FINISH\b/ ) {
600 |  |  |  |  | $goon = 0;
601 |  |  |  |  | }
602 |  |  |  |  | }
603 |  |  |  |  | elsif ( $eval_error ne '' ) {
604 |  |  |  |  | warn ($eval_error);
605 |  |  |  |  | $error++;
606 |  |  |  |  | }
607 |  |  |  |  | }
608 |  |  |  |  | else {
609 |  |  |  |  | print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
610 |  |  |  |  | "\" in linkage\n");
611 |  |  |  |  | die("Getopt::Long -- internal error!\n");
612 |  |  |  |  | }
613 |  |  |  |  | }
614 |  |  |  |  | # No entry in linkage means entry in userlinkage.
615 |  |  |  |  | elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
616 |  |  |  |  | if ( defined $userlinkage->{$opt} ) {
617 |  |  |  |  | print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
618 |  |  |  |  | if $debug;
619 |  |  |  |  | push (@{$userlinkage->{$opt}}, $arg);
620 |  |  |  |  | }
621 |  |  |  |  | else {
622 |  |  |  |  | print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
623 |  |  |  |  | if $debug;
624 |  |  |  |  | $userlinkage->{$opt} = [$arg];
625 |  |  |  |  | }
626 |  |  |  |  | }
627 |  |  |  |  | elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
628 |  |  |  |  | if ( defined $userlinkage->{$opt} ) {
629 |  |  |  |  | print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
630 |  |  |  |  | if $debug;
631 |  |  |  |  | $userlinkage->{$opt}->{$key} = $arg;
632 |  |  |  |  | }
633 |  |  |  |  | else {
634 |  |  |  |  | print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
635 |  |  |  |  | if $debug;
636 |  |  |  |  | $userlinkage->{$opt} = {$key => $arg};
637 |  |  |  |  | }
638 |  |  |  |  | }
639 |  |  |  |  | else {
640 |  |  |  |  | if ( $ctl->[CTL_TYPE] eq '+' ) {
641 |  |  |  |  | print STDERR ("=> \$L{$opt} += \"$arg\"\n")
642 |  |  |  |  | if $debug;
643 |  |  |  |  | if ( defined $userlinkage->{$opt} ) {
644 |  |  |  |  | $userlinkage->{$opt} += $arg;
645 |  |  |  |  | }
646 |  |  |  |  | else {
647 |  |  |  |  | $userlinkage->{$opt} = $arg;
648 |  |  |  |  | }
649 |  |  |  |  | }
650 |  |  |  |  | else {
651 |  |  |  |  | print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
652 |  |  |  |  | $userlinkage->{$opt} = $arg;
653 |  |  |  |  | }
654 |  |  |  |  | }
655 |  |  |  |  |
656 |  |  |  |  | $argcnt++;
657 |  |  |  |  | last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
658 |  |  |  |  | undef($arg);
659 |  |  |  |  |
660 |  |  |  |  | # Need more args?
661 |  |  |  |  | if ( $argcnt < $ctl->[CTL_AMIN] ) {
662 |  |  |  |  | if ( @$argv ) {
663 |  |  |  |  | if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
664 |  |  |  |  | $arg = shift(@$argv);
665 |  |  |  |  | $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
666 |  |  |  |  | ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
667 |  |  |  |  | if $ctl->[CTL_DEST] == CTL_DEST_HASH;
668 |  |  |  |  | next;
669 |  |  |  |  | }
670 |  |  |  |  | warn("Value \"$$argv[0]\" invalid for option $opt\n");
671 |  |  |  |  | $error++;
672 |  |  |  |  | }
673 |  |  |  |  | else {
674 |  |  |  |  | warn("Insufficient arguments for option $opt\n");
675 |  |  |  |  | $error++;
676 |  |  |  |  | }
677 |  |  |  |  | }
678 |  |  |  |  |
679 |  |  |  |  | # Any more args?
680 |  |  |  |  | if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
681 |  |  |  |  | $arg = shift(@$argv);
682 |  |  |  |  | $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
683 |  |  |  |  | ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
684 |  |  |  |  | if $ctl->[CTL_DEST] == CTL_DEST_HASH;
685 |  |  |  |  | next;
686 |  |  |  |  | }
687 |  |  |  |  | }
688 |  |  |  |  | }
689 |  |  |  |  |
690 |  |  |  |  | # Not an option. Save it if we $PERMUTE and don't have a <>.
691 |  |  |  |  | elsif ( $order == $PERMUTE ) {
692 |  |  |  |  | # Try non-options call-back.
693 |  |  |  |  | my $cb;
694 | 2 | 5µs |  |  | 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 | 2 | 4µ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 |  |  |  |  | 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 758µs (628+130) within Getopt::Long::ParseOptionSpec which was called 7 times, avg 108µs/call: # 7 times (628µs+130µs) by Getopt::Long::GetOptionsFromArray at line 366, avg 108µs/call sub ParseOptionSpec ($$) {
771 | 91 | 390µs |  |  | my ($opt, $opctl) = @_;
772 |  |  |  |  |
773 |  |  |  |  | # Match option spec.
774 |  |  | 7 | 72µs | if ( $opt !~ m;^ # spent 72µs making 7 calls to Getopt::Long::CORE:match, avg 10µs/call
775 |  |  |  |  | (
776 |  |  |  |  | # Option name
777 |  |  |  |  | (?: \w+[-\w]* )
778 |  |  |  |  | # Alias names, or "?"
779 |  |  |  |  | (?: \| (?: \? | \w[-\w]* ) )*
780 |  |  |  |  | )?
781 |  |  |  |  | (
782 |  |  |  |  | # Either modifiers ...
783 |  |  |  |  | [!+]
784 |  |  |  |  | |
785 |  |  |  |  | # ... or a value/dest/repeat specification
786 |  |  |  |  | [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
787 |  |  |  |  | |
788 |  |  |  |  | # ... or an optional-with-default spec
789 |  |  |  |  | : (?: -?\d+ | \+ ) [@%]?
790 |  |  |  |  | )?
791 |  |  |  |  | $;x ) {
792 |  |  |  |  | return (undef, "Error in option spec: \"$opt\"\n");
793 |  |  |  |  | }
794 |  |  |  |  |
795 |  |  |  |  | my ($names, $spec) = ($1, $2);
796 |  |  |  |  | $spec = '' unless defined $spec;
797 |  |  |  |  |
798 |  |  |  |  | # $orig keeps track of the primary name the user specified.
799 |  |  |  |  | # This name will be used for the internal or external linkage.
800 |  |  |  |  | # In other words, if the user specifies "FoO|BaR", it will
801 |  |  |  |  | # match any case combinations of 'foo' and 'bar', but if a global
802 |  |  |  |  | # variable needs to be set, it will be $opt_FoO in the exact case
803 |  |  |  |  | # as specified.
804 |  |  |  |  | my $orig;
805 |  |  |  |  |
806 |  |  |  |  | my @names;
807 | 14 | 51µs |  |  | if ( defined $names ) {
808 |  |  |  |  | @names = split (/\|/, $names);
809 |  |  |  |  | $orig = $names[0];
810 |  |  |  |  | }
811 |  |  |  |  | else {
812 |  |  |  |  | @names = ('');
813 |  |  |  |  | $orig = '';
814 |  |  |  |  | }
815 |  |  |  |  |
816 |  |  |  |  | # Construct the opctl entries.
817 |  |  |  |  | my $entry;
818 | 65 | 224µs | 5 | 8µs | if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { # spent 8µs making 5 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 |  |  | 5 | 51µs | my ($mand, $type, $dest) = # spent 51µs making 5 calls to Getopt::Long::CORE:match, avg 10µs/call
835 |  |  |  |  | $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
836 |  |  |  |  | return (undef, "Cannot repeat while bundling: \"$opt\"\n")
837 |  |  |  |  | if $bundling && defined($4);
838 |  |  |  |  | my ($mi, $cm, $ma) = ($5, $6, $7);
839 |  |  |  |  | return (undef, "{0} is useless in option spec: \"$opt\"\n")
840 |  |  |  |  | if defined($mi) && !$mi && !defined($ma) && !defined($cm);
841 |  |  |  |  |
842 |  |  |  |  | $type = 'i' if $type eq 'n';
843 |  |  |  |  | $dest ||= '$';
844 |  |  |  |  | $dest = $dest eq '@' ? CTL_DEST_ARRAY
845 |  |  |  |  | : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
846 |  |  |  |  | # Default minargs to 1/0 depending on mand status.
847 |  |  |  |  | $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
848 |  |  |  |  | # Adjust mand status according to minargs.
849 |  |  |  |  | $mand = $mi ? '=' : ':';
850 |  |  |  |  | # Adjust maxargs.
851 |  |  |  |  | $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
852 |  |  |  |  | return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
853 |  |  |  |  | if defined($ma) && !$ma;
854 |  |  |  |  | return (undef, "Max less than min in option spec: \"$opt\"\n")
855 |  |  |  |  | if defined($ma) && $ma < $mi;
856 |  |  |  |  |
857 |  |  |  |  | # Fields are hard-wired here.
858 |  |  |  |  | $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
859 |  |  |  |  | }
860 |  |  |  |  |
861 |  |  |  |  | # Process all names. First is canonical, the rest are aliases.
862 |  |  |  |  | my $dups = '';
863 |  |  |  |  | foreach ( @names ) {
864 |  |  |  |  |
865 | 36 | 81µs |  |  | $_ = lc ($_)
866 |  |  |  |  | if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
867 |  |  |  |  |
868 |  |  |  |  | if ( exists $opctl->{$_} ) {
869 |  |  |  |  | $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
870 |  |  |  |  | }
871 |  |  |  |  |
872 | 12 | 34µs |  |  | if ( $spec eq '!' ) {
873 |  |  |  |  | $opctl->{"no$_"} = $entry;
874 |  |  |  |  | $opctl->{"no-$_"} = $entry;
875 |  |  |  |  | $opctl->{$_} = [@$entry];
876 |  |  |  |  | $opctl->{$_}->[CTL_TYPE] = '';
877 |  |  |  |  | }
878 |  |  |  |  | else {
879 |  |  |  |  | $opctl->{$_} = $entry;
880 |  |  |  |  | }
881 |  |  |  |  | }
882 |  |  |  |  |
883 |  |  |  |  | if ( $dups && $^W ) {
884 |  |  |  |  | foreach ( split(/\n+/, $dups) ) {
885 |  |  |  |  | warn($_."\n");
886 |  |  |  |  | }
887 |  |  |  |  | }
888 |  |  |  |  | ($names[0], $orig);
889 |  |  |  |  | }
890 |  |  |  |  |
891 |  |  |  |  | # Option lookup.
892 |  |  |  |  | # spent 84µs (34+50) within Getopt::Long::FindOption which was called: # once (34µs+50µs) by Getopt::Long::GetOptionsFromArray at line 506 sub FindOption ($$$$$) {
893 |  |  |  |  |
894 |  |  |  |  | # returns (1, $opt, $ctl, $arg, $key) if okay,
895 |  |  |  |  | # returns (1, undef) if option in error,
896 |  |  |  |  | # returns (0) otherwise.
897 |  |  |  |  |
898 | 3 | 89µs |  |  | my ($argv, $prefix, $argend, $opt, $opctl) = @_;
899 |  |  |  |  |
900 |  |  |  |  | print STDERR ("=> find \"$opt\"\n") if $debug;
901 |  |  |  |  |
902 |  |  | 2 | 50µs | return (0) unless $opt =~ /^$prefix(.*)$/s; # spent 46µs making 1 call to Getopt::Long::CORE:regcomp # spent 4µs making 1 call to Getopt::Long::CORE:match
903 |  |  |  |  | return (0) if $opt eq "-" && !defined $opctl->{''};
904 |  |  |  |  |
905 |  |  |  |  | $opt = $+;
906 |  |  |  |  | my $starter = $1;
907 |  |  |  |  |
908 |  |  |  |  | print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
909 |  |  |  |  |
910 |  |  |  |  | my $optarg; # value supplied with --opt=value
911 |  |  |  |  | my $rest; # remainder from unbundling
912 |  |  |  |  |
913 |  |  |  |  | # If it is a long option, it may include the value.
914 |  |  |  |  | # With getopt_compat, only if not bundling.
915 |  |  |  |  | if ( ($starter=~/^$longprefix$/
916 |  |  |  |  | || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
917 |  |  |  |  | && $opt =~ /^([^=]+)=(.*)$/s ) {
918 |  |  |  |  | $opt = $1;
919 |  |  |  |  | $optarg = $2;
920 |  |  |  |  | print STDERR ("=> option \"", $opt,
921 |  |  |  |  | "\", optarg = \"$optarg\"\n") if $debug;
922 |  |  |  |  | }
923 |  |  |  |  |
924 |  |  |  |  | #### Look it up ###
925 |  |  |  |  |
926 |  |  |  |  | my $tryopt = $opt; # option to try
927 |  |  |  |  |
928 |  |  |  |  | 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 |  |  |  |  | my @names = sort(keys (%$opctl));
955 |  |  |  |  | # Downcase if allowed.
956 |  |  |  |  | $opt = lc ($opt) if $ignorecase;
957 |  |  |  |  | $tryopt = $opt;
958 |  |  |  |  | # Turn option name into pattern.
959 |  |  |  |  | my $pat = quotemeta ($opt);
960 |  |  |  |  | # Look up in option names.
961 |  |  |  |  | my @hits = grep (/^$pat/, @names);
962 |  |  |  |  | print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
963 |  |  |  |  | "out of ", scalar(@names), "\n") if $debug;
964 |  |  |  |  |
965 |  |  |  |  | # Check for ambiguous results.
966 |  |  |  |  | unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
967 |  |  |  |  | # See if all matches are for the same option.
968 |  |  |  |  | my %hit;
969 |  |  |  |  | foreach ( @hits ) {
970 |  |  |  |  | my $hit = $_;
971 |  |  |  |  | $hit = $opctl->{$hit}->[CTL_CNAME]
972 |  |  |  |  | if defined $opctl->{$hit}->[CTL_CNAME];
973 |  |  |  |  | $hit{$hit} = 1;
974 |  |  |  |  | }
975 |  |  |  |  | # Remove auto-supplied options (version, help).
976 |  |  |  |  | if ( keys(%hit) == 2 ) {
977 |  |  |  |  | if ( $auto_version && exists($hit{version}) ) {
978 |  |  |  |  | delete $hit{version};
979 |  |  |  |  | }
980 |  |  |  |  | elsif ( $auto_help && exists($hit{help}) ) {
981 |  |  |  |  | delete $hit{help};
982 |  |  |  |  | }
983 |  |  |  |  | }
984 |  |  |  |  | # Now see if it really is ambiguous.
985 |  |  |  |  | unless ( keys(%hit) == 1 ) {
986 |  |  |  |  | return (0) if $passthrough;
987 |  |  |  |  | warn ("Option ", $opt, " is ambiguous (",
988 |  |  |  |  | join(", ", @hits), ")\n");
989 |  |  |  |  | $error++;
990 |  |  |  |  | return (1, undef);
991 |  |  |  |  | }
992 |  |  |  |  | @hits = keys(%hit);
993 |  |  |  |  | }
994 |  |  |  |  |
995 |  |  |  |  | # Complete the option name, if appropriate.
996 |  |  |  |  | if ( @hits == 1 && $hits[0] ne $opt ) {
997 |  |  |  |  | $tryopt = $hits[0];
998 |  |  |  |  | $tryopt = lc ($tryopt) if $ignorecase;
999 |  |  |  |  | print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
1000 |  |  |  |  | if $debug;
1001 |  |  |  |  | }
1002 |  |  |  |  | }
1003 |  |  |  |  |
1004 |  |  |  |  | # Map to all lowercase if ignoring case.
1005 |  |  |  |  | elsif ( $ignorecase ) {
1006 |  |  |  |  | $tryopt = lc ($opt);
1007 |  |  |  |  | }
1008 |  |  |  |  |
1009 |  |  |  |  | # Check validity by fetching the info.
1010 |  |  |  |  | my $ctl = $opctl->{$tryopt};
1011 |  |  |  |  | unless ( defined $ctl ) {
1012 |  |  |  |  | return (0) if $passthrough;
1013 |  |  |  |  | # Pretend one char when bundling.
1014 |  |  |  |  | if ( $bundling == 1 && length($starter) == 1 ) {
1015 |  |  |  |  | $opt = substr($opt,0,1);
1016 |  |  |  |  | unshift (@$argv, $starter.$rest) if defined $rest;
1017 |  |  |  |  | }
1018 |  |  |  |  | if ( $opt eq "" ) {
1019 |  |  |  |  | warn ("Missing option after ", $starter, "\n");
1020 |  |  |  |  | }
1021 |  |  |  |  | else {
1022 |  |  |  |  | warn ("Unknown option: ", $opt, "\n");
1023 |  |  |  |  | }
1024 |  |  |  |  | $error++;
1025 |  |  |  |  | return (1, undef);
1026 |  |  |  |  | }
1027 |  |  |  |  | # Apparently valid.
1028 |  |  |  |  | $opt = $tryopt;
1029 |  |  |  |  | print STDERR ("=> found ", OptCtl($ctl),
1030 |  |  |  |  | " for \"", $opt, "\"\n") if $debug;
1031 |  |  |  |  |
1032 |  |  |  |  | #### Determine argument status ####
1033 |  |  |  |  |
1034 |  |  |  |  | # If it is an option w/o argument, we're almost finished with it.
1035 |  |  |  |  | my $type = $ctl->[CTL_TYPE];
1036 |  |  |  |  | my $arg;
1037 |  |  |  |  |
1038 |  |  |  |  | if ( $type eq '' || $type eq '!' || $type eq '+' ) {
1039 |  |  |  |  | if ( defined $optarg ) {
1040 |  |  |  |  | return (0) if $passthrough;
1041 |  |  |  |  | warn ("Option ", $opt, " does not take an argument\n");
1042 |  |  |  |  | $error++;
1043 |  |  |  |  | undef $opt;
1044 |  |  |  |  | }
1045 |  |  |  |  | elsif ( $type eq '' || $type eq '+' ) {
1046 |  |  |  |  | # Supply explicit value.
1047 |  |  |  |  | $arg = 1;
1048 |  |  |  |  | }
1049 |  |  |  |  | else {
1050 |  |  |  |  | $opt =~ s/^no-?//i; # strip NO prefix
1051 |  |  |  |  | $arg = 0; # supply explicit value
1052 |  |  |  |  | }
1053 |  |  |  |  | unshift (@$argv, $starter.$rest) if defined $rest;
1054 |  |  |  |  | return (1, $opt, $ctl, $arg);
1055 |  |  |  |  | }
1056 |  |  |  |  |
1057 |  |  |  |  | # Get mandatory status and type info.
1058 |  |  |  |  | my $mand = $ctl->[CTL_AMIN];
1059 |  |  |  |  |
1060 |  |  |  |  | # Check if there is an option argument available.
1061 |  |  |  |  | if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
1062 |  |  |  |  | return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
1063 |  |  |  |  | $optarg = 0 unless $type eq 's';
1064 |  |  |  |  | }
1065 |  |  |  |  |
1066 |  |  |  |  | # Check if there is an option argument available.
1067 |  |  |  |  | if ( defined $optarg
1068 |  |  |  |  | ? ($optarg eq '')
1069 |  |  |  |  | : !(defined $rest || @$argv > 0) ) {
1070 |  |  |  |  | # Complain if this option needs an argument.
1071 |  |  |  |  | # if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
1072 |  |  |  |  | if ( $mand ) {
1073 |  |  |  |  | return (0) if $passthrough;
1074 |  |  |  |  | warn ("Option ", $opt, " requires an argument\n");
1075 |  |  |  |  | $error++;
1076 |  |  |  |  | return (1, undef);
1077 |  |  |  |  | }
1078 |  |  |  |  | if ( $type eq 'I' ) {
1079 |  |  |  |  | # Fake incremental type.
1080 |  |  |  |  | my @c = @$ctl;
1081 |  |  |  |  | $c[CTL_TYPE] = '+';
1082 |  |  |  |  | return (1, $opt, \@c, 1);
1083 |  |  |  |  | }
1084 |  |  |  |  | return (1, $opt, $ctl,
1085 |  |  |  |  | defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1086 |  |  |  |  | $type eq 's' ? '' : 0);
1087 |  |  |  |  | }
1088 |  |  |  |  |
1089 |  |  |  |  | # Get (possibly optional) argument.
1090 |  |  |  |  | $arg = (defined $rest ? $rest
1091 |  |  |  |  | : (defined $optarg ? $optarg : shift (@$argv)));
1092 |  |  |  |  |
1093 |  |  |  |  | # Get key if this is a "name=value" pair for a hash option.
1094 |  |  |  |  | my $key;
1095 |  |  |  |  | if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
1096 |  |  |  |  | ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
1097 |  |  |  |  | : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
1098 |  |  |  |  | ($mand ? undef : ($type eq 's' ? "" : 1)));
1099 |  |  |  |  | if (! defined $arg) {
1100 |  |  |  |  | warn ("Option $opt, key \"$key\", requires a value\n");
1101 |  |  |  |  | $error++;
1102 |  |  |  |  | # Push back.
1103 |  |  |  |  | unshift (@$argv, $starter.$rest) if defined $rest;
1104 |  |  |  |  | return (1, undef);
1105 |  |  |  |  | }
1106 |  |  |  |  | }
1107 |  |  |  |  |
1108 |  |  |  |  | #### Check if the argument is valid for this option ####
1109 |  |  |  |  |
1110 |  |  |  |  | my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
1111 |  |  |  |  |
1112 |  |  |  |  | if ( $type eq 's' ) { # string
1113 |  |  |  |  | # A mandatory string takes anything.
1114 |  |  |  |  | return (1, $opt, $ctl, $arg, $key) if $mand;
1115 |  |  |  |  |
1116 |  |  |  |  | # Same for optional string as a hash value
1117 |  |  |  |  | return (1, $opt, $ctl, $arg, $key)
1118 |  |  |  |  | if $ctl->[CTL_DEST] == CTL_DEST_HASH;
1119 |  |  |  |  |
1120 |  |  |  |  | # An optional string takes almost anything.
1121 |  |  |  |  | return (1, $opt, $ctl, $arg, $key)
1122 |  |  |  |  | if defined $optarg || defined $rest;
1123 |  |  |  |  | return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
1124 |  |  |  |  |
1125 |  |  |  |  | # Check for option or option list terminator.
1126 |  |  |  |  | if ($arg eq $argend ||
1127 |  |  |  |  | $arg =~ /^$prefix.+/) {
1128 |  |  |  |  | # Push back.
1129 |  |  |  |  | unshift (@$argv, $arg);
1130 |  |  |  |  | # Supply empty value.
1131 |  |  |  |  | $arg = '';
1132 |  |  |  |  | }
1133 |  |  |  |  | }
1134 |  |  |  |  |
1135 |  |  |  |  | elsif ( $type eq 'i' # numeric/integer
1136 |  |  |  |  | || $type eq 'I' # numeric/integer w/ incr default
1137 |  |  |  |  | || $type eq 'o' ) { # dec/oct/hex/bin value
1138 |  |  |  |  |
1139 |  |  |  |  | my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
1140 |  |  |  |  |
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 316µs (309+7) within Getopt::Long::Configure which was called 5 times, avg 63µs/call: # once (131µs+0s) by Getopt::Long::Parser::configure at line 173 # once (82µs+7µs) by Getopt::Long::Parser::configure at line 170 # once (35µs+0s) by Getopt::Long::Parser::getoptions at line 195 # once (33µs+0s) by App::Rad::getopt at line 133 # once (28µs+0s) by Getopt::Long::Parser::getoptions at line 180 sub Configure (@) {
1267 | 30 | 160µs |  |  | my (@options) = @_;
1268 |  |  |  |  |
1269 |  |  |  |  | my $prevconfig =
1270 |  |  |  |  | [ $error, $debug, $major_version, $minor_version,
1271 |  |  |  |  | $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
1272 |  |  |  |  | $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
1273 |  |  |  |  | $longprefix ];
1274 |  |  |  |  |
1275 | 4 | 137µ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 |  |  |  |  | my $opt;
1283 |  |  |  |  | foreach $opt ( @options ) {
1284 | 4 | 51µs |  |  | my $try = lc ($opt);
1285 |  |  |  |  | my $action = 1;
1286 |  |  | 1 | 3µs | if ( $try =~ /^no_?(.*)$/s ) { # spent 3µs making 1 call to Getopt::Long::CORE:match
1287 |  |  |  |  | $action = 0;
1288 |  |  |  |  | $try = $+;
1289 |  |  |  |  | }
1290 | 1 | 1µs | 2 | 4µs | if ( ($try eq 'default' or $try eq 'defaults') && $action ) { # spent 4µs making 2 calls to Getopt::Long::CORE:match, avg 2µs/call
1291 |  |  |  |  | ConfigDefaults ();
1292 |  |  |  |  | }
1293 |  |  |  |  | elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
1294 |  |  |  |  | local $ENV{POSIXLY_CORRECT};
1295 |  |  |  |  | $ENV{POSIXLY_CORRECT} = 1 if $action;
1296 |  |  |  |  | ConfigDefaults ();
1297 |  |  |  |  | }
1298 |  |  |  |  | elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
1299 |  |  |  |  | $autoabbrev = $action;
1300 |  |  |  |  | }
1301 |  |  |  |  | elsif ( $try eq 'getopt_compat' ) {
1302 |  |  |  |  | $getopt_compat = $action;
1303 |  |  |  |  | $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
1304 |  |  |  |  | }
1305 |  |  |  |  | elsif ( $try eq 'gnu_getopt' ) {
1306 |  |  |  |  | if ( $action ) {
1307 |  |  |  |  | $gnu_compat = 1;
1308 |  |  |  |  | $bundling = 1;
1309 |  |  |  |  | $getopt_compat = 0;
1310 |  |  |  |  | $genprefix = "(--|-)";
1311 |  |  |  |  | $order = $PERMUTE;
1312 |  |  |  |  | }
1313 |  |  |  |  | }
1314 |  |  |  |  | elsif ( $try eq 'gnu_compat' ) {
1315 |  |  |  |  | $gnu_compat = $action;
1316 |  |  |  |  | }
1317 |  |  |  |  | elsif ( $try =~ /^(auto_?)?version$/ ) {
1318 |  |  |  |  | $auto_version = $action;
1319 |  |  |  |  | }
1320 |  |  |  |  | elsif ( $try =~ /^(auto_?)?help$/ ) {
1321 |  |  |  |  | $auto_help = $action;
1322 |  |  |  |  | }
1323 |  |  |  |  | elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
1324 |  |  |  |  | $ignorecase = $action;
1325 |  |  |  |  | }
1326 |  |  |  |  | elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
1327 |  |  |  |  | $ignorecase = $action ? 2 : 0;
1328 |  |  |  |  | }
1329 |  |  |  |  | elsif ( $try eq 'bundling' ) {
1330 |  |  |  |  | $bundling = $action;
1331 |  |  |  |  | }
1332 |  |  |  |  | elsif ( $try eq 'bundling_override' ) {
1333 |  |  |  |  | $bundling = $action ? 2 : 0;
1334 |  |  |  |  | }
1335 |  |  |  |  | elsif ( $try eq 'require_order' ) {
1336 |  |  |  |  | $order = $action ? $REQUIRE_ORDER : $PERMUTE;
1337 |  |  |  |  | }
1338 |  |  |  |  | elsif ( $try eq 'permute' ) {
1339 |  |  |  |  | $order = $action ? $PERMUTE : $REQUIRE_ORDER;
1340 |  |  |  |  | }
1341 |  |  |  |  | elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
1342 |  |  |  |  | $passthrough = $action;
1343 |  |  |  |  | }
1344 |  |  |  |  | elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
1345 |  |  |  |  | $genprefix = $1;
1346 |  |  |  |  | # Turn into regexp. Needs to be parenthesized!
1347 |  |  |  |  | $genprefix = "(" . quotemeta($genprefix) . ")";
1348 |  |  |  |  | eval { '' =~ /$genprefix/; };
1349 |  |  |  |  | die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1350 |  |  |  |  | }
1351 |  |  |  |  | elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
1352 |  |  |  |  | $genprefix = $1;
1353 |  |  |  |  | # Parenthesize if needed.
1354 |  |  |  |  | $genprefix = "(" . $genprefix . ")"
1355 |  |  |  |  | unless $genprefix =~ /^\(.*\)$/;
1356 |  |  |  |  | eval { '' =~ m"$genprefix"; };
1357 |  |  |  |  | die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
1358 |  |  |  |  | }
1359 |  |  |  |  | elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
1360 |  |  |  |  | $longprefix = $1;
1361 |  |  |  |  | # Parenthesize if needed.
1362 |  |  |  |  | $longprefix = "(" . $longprefix . ")"
1363 |  |  |  |  | unless $longprefix =~ /^\(.*\)$/;
1364 |  |  |  |  | eval { '' =~ m"$longprefix"; };
1365 |  |  |  |  | die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
1366 |  |  |  |  | }
1367 |  |  |  |  | elsif ( $try eq 'debug' ) {
1368 |  |  |  |  | $debug = $action;
1369 |  |  |  |  | }
1370 |  |  |  |  | else {
1371 |  |  |  |  | die("Getopt::Long: unknown config parameter \"$opt\"")
1372 |  |  |  |  | }
1373 |  |  |  |  | }
1374 |  |  |  |  | $prevconfig;
1375 |  |  |  |  | }
1376 |  |  |  |  |
1377 |  |  |  |  | # Deprecated name.
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 | 217µs | # spent 272µs (55+217) within Getopt::Long::CallBack::BEGIN@1489 which was called: # once (55µs+217µs) by App::Rad::getopt at line 1490 '""' => \&name, # spent 217µs making 1 call to overload::import
1490 | 2 | 3.16ms | 1 | 272µs | fallback => 1; # spent 272µs making 1 call to Getopt::Long::CallBack::BEGIN@1489
1491 |  |  |  |  |
1492 | 1 | 34µ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 234µs within Getopt::Long::CORE:match which was called 30 times, avg 8µs/call: # 7 times (72µs+0s) by Getopt::Long::ParseOptionSpec at line 774, avg 10µs/call # 7 times (39µs+0s) by Getopt::Long::GetOptionsFromArray at line 344, avg 6µs/call # 5 times (51µs+0s) by Getopt::Long::ParseOptionSpec at line 834, avg 10µs/call # 5 times (8µs+0s) by Getopt::Long::ParseOptionSpec at line 818, avg 2µs/call # 2 times (4µs+0s) by Getopt::Long::Configure at line 1290, avg 2µs/call # once (45µs+0s) by App::Rad::getopt at line 123 # once (9µs+0s) by Getopt::Long::GetOptionsFromArray at line 322 # once (4µs+0s) by Getopt::Long::FindOption at line 902 # once (3µs+0s) by Getopt::Long::Configure at line 1286 sub Getopt::Long::CORE:match; # opcode
|  |  |  |  | # spent 149µs within Getopt::Long::CORE:regcomp which was called 8 times, avg 19µs/call: # 7 times (104µs+0s) by Getopt::Long::GetOptionsFromArray at line 344, avg 15µs/call # once (46µs+0s) by Getopt::Long::FindOption at line 902 sub Getopt::Long::CORE:regcomp; # opcode