Profile of Getopt/Long.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/share/perl/5.18/Getopt/Long.pm
Statements | Executed 1488 statements in 8.53ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
24 | 1 | 1 | 741µs | 910µs | Getopt::Long::::ParseOptionSpec Getopt::Long::ParseOptionSpec
3 | 2 | 1 | 550µs | 1.78ms | Getopt::Long::::GetOptionsFromArray Getopt::Long::GetOptionsFromArray
120 | 11 | 1 | 272µs | 272µs | Getopt::Long::::CORE:match Getopt::Long::CORE:match (opcode)
7 | 6 | 2 | 177µs | 203µs | Getopt::Long::::Configure Getopt::Long::Configure
32 | 4 | 1 | 126µs | 126µs | Getopt::Long::::CORE:regcomp Getopt::Long::CORE:regcomp (opcode)
4 | 1 | 1 | 121µs | 198µs | Getopt::Long::::FindOption Getopt::Long::FindOption
1 | 1 | 1 | 50µs | 149µs | Getopt::Long::Parser::::new Getopt::Long::Parser::new
1 | 1 | 1 | 44µs | 1.55ms | Getopt::Long::Parser::::getoptionsfromarray Getopt::Long::Parser::getoptionsfromarray
1 | 1 | 1 | 17µs | 17µs | Getopt::Long::::BEGIN@15 Getopt::Long::BEGIN@15
1 | 1 | 1 | 13µs | 1.57ms | Getopt::Long::Parser::::getoptions Getopt::Long::Parser::getoptions
1 | 1 | 1 | 12µs | 148µs | Getopt::Long::::import Getopt::Long::import
1 | 1 | 1 | 11µs | 45µs | Getopt::Long::CallBack::::BEGIN@1506Getopt::Long::CallBack::BEGIN@1506
1 | 1 | 1 | 10µs | 27µs | Getopt::Long::::BEGIN@243 Getopt::Long::BEGIN@243
1 | 1 | 1 | 9µs | 45µs | Getopt::Long::::BEGIN@215 Getopt::Long::BEGIN@215
1 | 1 | 1 | 9µs | 25µs | Getopt::Long::::BEGIN@25 Getopt::Long::BEGIN@25
1 | 1 | 1 | 9µs | 19µs | Getopt::Long::::VERSION Getopt::Long::VERSION
2 | 1 | 1 | 8µs | 8µs | Getopt::Long::::GetOptions Getopt::Long::GetOptions
1 | 1 | 1 | 7µs | 15µs | Getopt::Long::::BEGIN@17 Getopt::Long::BEGIN@17
1 | 1 | 1 | 7µs | 28µs | Getopt::Long::::BEGIN@225 Getopt::Long::BEGIN@225
1 | 1 | 1 | 6µs | 54µs | Getopt::Long::::BEGIN@48 Getopt::Long::BEGIN@48
1 | 1 | 1 | 6µs | 26µs | Getopt::Long::::BEGIN@19 Getopt::Long::BEGIN@19
1 | 1 | 1 | 6µs | 38µs | Getopt::Long::::BEGIN@26 Getopt::Long::BEGIN@26
1 | 1 | 1 | 6µs | 25µs | Getopt::Long::::BEGIN@232 Getopt::Long::BEGIN@232
1 | 1 | 1 | 6µs | 25µs | Getopt::Long::::BEGIN@229 Getopt::Long::BEGIN@229
1 | 1 | 1 | 6µs | 28µs | Getopt::Long::::BEGIN@230 Getopt::Long::BEGIN@230
1 | 1 | 1 | 5µs | 44µs | Getopt::Long::::BEGIN@46 Getopt::Long::BEGIN@46
1 | 1 | 1 | 5µs | 25µs | Getopt::Long::::BEGIN@244 Getopt::Long::BEGIN@244
1 | 1 | 1 | 5µs | 24µs | Getopt::Long::::BEGIN@254 Getopt::Long::BEGIN@254
1 | 1 | 1 | 5µs | 20µs | Getopt::Long::::BEGIN@22 Getopt::Long::BEGIN@22
1 | 1 | 1 | 5µs | 25µs | Getopt::Long::::BEGIN@227 Getopt::Long::BEGIN@227
1 | 1 | 1 | 5µs | 23µs | Getopt::Long::::BEGIN@235 Getopt::Long::BEGIN@235
1 | 1 | 1 | 5µs | 81µs | Getopt::Long::::BEGIN@45 Getopt::Long::BEGIN@45
1 | 1 | 1 | 5µs | 22µs | Getopt::Long::::BEGIN@236 Getopt::Long::BEGIN@236
1 | 1 | 1 | 5µs | 23µs | Getopt::Long::::BEGIN@231 Getopt::Long::BEGIN@231
1 | 1 | 1 | 5µs | 23µs | Getopt::Long::::BEGIN@233 Getopt::Long::BEGIN@233
1 | 1 | 1 | 4µs | 52µs | Getopt::Long::::BEGIN@51 Getopt::Long::BEGIN@51
1 | 1 | 1 | 4µs | 4µs | Getopt::Long::::BEGIN@37 Getopt::Long::BEGIN@37
1 | 1 | 1 | 4µs | 4µs | Getopt::Long::::ConfigDefaults Getopt::Long::ConfigDefaults
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::Parser::::configure Getopt::Long::Parser::configure
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::::setup_pa_args Getopt::Long::setup_pa_args

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

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