File Coverage

blib/lib/Getopt/Long/Less.pm
Criterion Covered Total %
statement 156 185 84.3
branch 88 120 73.3
condition 57 85 67.0
subroutine 11 13 84.6
pod 0 4 0.0
total 312 407 76.6


line stmt bran cond sub pod time code
1             package Getopt::Long::Less;
2              
3             our $DATE = '2019-02-02'; # DATE
4             our $VERSION = '0.090'; # VERSION
5              
6 1     1   579 use 5.010001;
  1         9  
7 1     1   5 use strict 'subs', 'vars';
  1         2  
  1         2121  
8             # IFUNBUILT
9             # use warnings;
10             # END IFUNBUILT
11              
12             our @EXPORT = qw(GetOptions);
13             our @EXPORT_OK = qw(Configure GetOptionsFromArray);
14              
15             my $Opts = {};
16              
17             sub import {
18 1     1   9 my $pkg = shift;
19 1         2 my $caller = caller;
20 1 50       5 my @imp = @_ ? @_ : @EXPORT;
21 1         2 for my $imp (@imp) {
22 3 50       6 if (grep {$_ eq $imp} (@EXPORT, @EXPORT_OK)) {
  9         19  
23 3         4 *{"$caller\::$imp"} = \&{$imp};
  3         38  
  3         7  
24             } else {
25 0         0 die "$imp is not exported by ".__PACKAGE__;
26             }
27             }
28             }
29              
30             sub Configure {
31 0     0 0 0 my $old_opts = {%$Opts};
32              
33 0 0       0 if (ref($_[0]) eq 'HASH') {
34 0         0 $Opts->{$_} = $_[0]{$_} for keys %{$_[0]};
  0         0  
35             } else {
36 0         0 for (@_) {
37 0 0       0 if ($_ eq 'no_ignore_case') { next }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
38 0         0 elsif ($_ eq 'bundling') { next }
39 0         0 elsif ($_ eq 'auto_abbrev') { next }
40 0         0 elsif ($_ eq 'gnu_compat') { next }
41 0         0 elsif ($_ eq 'no_getopt_compat') { next }
42 0         0 elsif ($_ eq 'permute') { next }
43 0         0 elsif (/\Ano_?require_order\z/) { next }
44             #elsif (/\A(no_?)?pass_through\z/) { $Opts->{pass_through} = $1 ?0:1 }
45 0         0 else { die "Unknown or erroneous config parameter \"$_\"\n" }
46             }
47             }
48 0         0 $old_opts;
49             }
50              
51             sub GetOptionsFromArray {
52 39     39 0 159879 my $argv = shift;
53              
54 39         78 my $vals;
55             my $spec;
56              
57             # if next argument is a hashref, it means user wants to store values in this
58             # hash. and the spec is a list.
59 39 100       106 if (ref($_[0]) eq 'HASH') {
60 35         50 $vals = shift;
61 35     33   67 $spec = {map { $_ => sub { $vals->{ $_[0]->name } = $_[1] } } @_};
  51         228  
  33         71  
62             } else {
63 4         10 $spec = {@_};
64             }
65              
66             # parse option spec
67 39         91 my %parsed_spec;
68 39         109 for my $k (keys %$spec) {
69 55 50       110 my $parsed = parse_getopt_long_opt_spec($k)
70             or die "Error in option spec: $k\n";
71 55 50       122 if (defined $parsed->{max_vals}) {
72 0         0 die "Cannot repeat while bundling: $k\n";
73             }
74 55         99 $parsed->{_orig} = $k;
75 55         180 $parsed_spec{$parsed->{opts}[0]} = $parsed;
76             }
77 39         140 my @parsed_spec_opts = sort keys %parsed_spec;
78              
79 39         65 my $success = 1;
80              
81             my $code_find_opt = sub {
82 53     53   106 my ($wanted, $short_mode) = @_;
83 53         71 my @candidates;
84             OPT_SPEC:
85 53         96 for my $opt (@parsed_spec_opts) {
86 81         165 my $s = $parsed_spec{$opt};
87 81         111 for my $o0 (@{ $s->{opts} }) {
  81         138  
88 92 100 66     224 for my $o ($s->{is_neg} && length($o0) > 1 ?
89             ($o0, "no$o0", "no-$o0") : ($o0)) {
90 95         157 my $is_neg = $o0 ne $o;
91 95 100 100     199 next if $short_mode && length($o) > 1;
92 84 100       199 if ($o eq $wanted) {
    100          
93             # perfect match, we immediately go with this one
94 47         124 @candidates = ([$opt, $is_neg]);
95 47         112 last OPT_SPEC;
96             } elsif (index($o, $wanted) == 0) {
97             # prefix match, collect candidates first
98 3         8 push @candidates, [$opt, $is_neg];
99 3         9 next OPT_SPEC;
100             }
101             }
102             }
103             }
104 53 100       142 if (!@candidates) {
    100          
105 4         148 warn "Unknown option: $wanted\n";
106 4         20 $success = 0;
107 4         18 return (undef, undef);
108             } elsif (@candidates > 1) {
109             warn "Option $wanted is ambiguous (" .
110 1         4 join(", ", map {$_->[0]} @candidates) . ")\n";
  2         44  
111 1         6 $success = 0;
112 1         6 return (undef, undef, 1);
113             }
114 48         110 return @{ $candidates[0] };
  48         204  
115 39         182 };
116              
117             my $code_set_val = sub {
118 46     46   78 my $is_neg = shift;
119 46         63 my $name = shift;
120              
121 46         68 my $parsed = $parsed_spec{$name};
122 46         68 my $spec_key = $parsed->{_orig};
123 46         61 my $destination = $spec->{$spec_key};
124 46         87 my $ref = ref $destination;
125              
126 46         64 my $val;
127 46 100       88 if (@_) {
128 28         44 $val = shift;
129             } else {
130 18 100 100     199 if ($parsed->{is_inc} && $ref eq 'SCALAR') {
    100 66        
    100 33        
    100 100        
    100 33        
      33        
      100        
      33        
      33        
      66        
      33        
131 3   50     10 $val = ($$destination // 0) + 1;
132             } elsif ($parsed->{is_inc} && $vals) {
133 1   50     6 $val = ($vals->{$name} // 0) + 1;
134             } elsif ($parsed->{type} && $parsed->{type} eq 'i' ||
135             $parsed->{opttype} && $parsed->{opttype} eq 'i') {
136 2         3 $val = 0;
137             } elsif ($parsed->{type} && $parsed->{type} eq 'f' ||
138             $parsed->{opttype} && $parsed->{opttype} eq 'f') {
139 1         3 $val = 0;
140             } elsif ($parsed->{type} && $parsed->{type} eq 's' ||
141             $parsed->{opttype} && $parsed->{opttype} eq 's') {
142 2         6 $val = '';
143             } else {
144 9 100       20 $val = $is_neg ? 0 : 1;
145             }
146             }
147              
148             # type checking
149 46 100 100     344 if ($parsed->{type} && $parsed->{type} eq 'i' ||
    100 100        
      100        
      100        
      100        
      66        
150             $parsed->{opttype} && $parsed->{opttype} eq 'i') {
151 8 100       37 unless ($val =~ /\A[+-]?\d+\z/) {
152 3         121 warn qq|Value "$val" invalid for option $name (number expected)\n|;
153 3         21 return 0;
154             }
155             } elsif ($parsed->{type} && $parsed->{type} eq 'f' ||
156             $parsed->{opttype} && $parsed->{opttype} eq 'f') {
157 11 100       84 unless ($val =~ /\A[+-]?(\d+(\.\d+)?|\.\d+)([Ee][+-]?\d+)?\z/) {
158 4         156 warn qq|Value "$val" invalid for option $name (number expected)\n|;
159 4         31 return 0;
160             }
161             }
162              
163 39 100       86 if ($ref eq 'CODE') {
    100          
164 34         86 my $cb = Getopt::Long::Less::Callback->new(
165             name => $name,
166             );
167 34         71 $destination->($cb, $val);
168             } elsif ($ref eq 'SCALAR') {
169 4         7 $$destination = $val;
170             } else {
171             # no nothing
172             }
173 39         166 1;
174 39         139 };
175              
176 39         63 my $i = -1;
177 39         58 my @remaining;
178             ELEM:
179 39         97 while (++$i < @$argv) {
180 54 100       296 if ($argv->[$i] eq '--') {
    100          
    100          
181              
182 2         7 push @remaining, @{$argv}[$i+1 .. @$argv-1];
  2         5  
183 2         5 last ELEM;
184              
185             } elsif ($argv->[$i] =~ /\A--(.+?)(?:=(.*))?\z/) {
186              
187 46         152 my ($used_name, $val_in_opt) = ($1, $2);
188 46         100 my ($opt, $is_neg, $is_ambig) = $code_find_opt->($used_name);
189 46 100       108 unless (defined $opt) {
190 5 100       18 push @remaining, $argv->[$i] unless $is_ambig;
191 5         17 next ELEM;
192             }
193              
194 41         63 my $spec = $parsed_spec{$opt};
195             # check whether option requires an argument
196 41 100 66     156 if ($spec->{type} ||
      100        
      100        
197             $spec->{opttype} &&
198             (defined($val_in_opt) && length($val_in_opt) || ($i+1 < @$argv && $argv->[$i+1] !~ /\A-/))) {
199 26 100       57 if (defined($val_in_opt)) {
200             # argument is taken after =
201 2 50       5 unless ($code_set_val->($is_neg, $opt, $val_in_opt)) {
202 0         0 $success = 0;
203 0         0 next ELEM;
204             }
205             } else {
206 24 100       53 if ($i+1 >= @$argv) {
207             # we are the last element
208 1         40 warn "Option $used_name requires an argument\n";
209 1         5 $success = 0;
210 1         4 last ELEM;
211             }
212             # take the next element as argument
213 23 50 66     57 if ($spec->{type} || $argv->[$i+1] !~ /\A-/) {
214 23         29 $i++;
215 23 100       46 unless ($code_set_val->($is_neg, $opt, $argv->[$i])) {
216 7         14 $success = 0;
217 7         26 next ELEM;
218             }
219             }
220             }
221             } else {
222 15 50       35 unless ($code_set_val->($is_neg, $opt)) {
223 0         0 $success = 0;
224 0         0 next ELEM;
225             }
226             }
227              
228             } elsif ($argv->[$i] =~ /\A-(.*)/) {
229              
230 4         11 my $str = $1;
231             SHORT_OPT:
232 4         19 while ($str =~ s/(.)//) {
233 7         16 my $used_name = $1;
234 7         18 my ($opt, $is_neg) = $code_find_opt->($1, 'short');
235 7 50       18 next SHORT_OPT unless defined $opt;
236              
237 7         12 my $spec = $parsed_spec{$opt};
238             # check whether option requires an argument
239 7 100 0     27 if ($spec->{type} ||
      33        
      66        
240             $spec->{opttype} &&
241             (length($str) || ($i+1 < @$argv && $argv->[$i+1] !~ /\A-/))) {
242 4 100       11 if (length $str) {
243             # argument is taken from $str
244 2 50       6 if ($code_set_val->($is_neg, $opt, $str)) {
245 2         7 next ELEM;
246             } else {
247 0         0 $success = 0;
248 0         0 next SHORT_OPT;
249             }
250             } else {
251 2 100       7 if ($i+1 >= @$argv) {
252             # we are the last element
253 1         42 warn "Option $used_name requires an argument\n";
254 1         5 $success = 0;
255 1         3 last ELEM;
256             }
257             # take the next element as argument
258 1 50 33     5 if ($spec->{type} || $argv->[$i+1] !~ /\A-/) {
259 1         2 $i++;
260 1 50       4 unless ($code_set_val->($is_neg, $opt, $argv->[$i])) {
261 0         0 $success = 0;
262 0         0 next ELEM;
263             }
264             }
265             }
266             } else {
267 3 50       9 unless ($code_set_val->($is_neg, $opt)) {
268 0         0 $success = 0;
269 0         0 next SHORT_OPT;
270             }
271             }
272             }
273              
274             } else { # argument
275              
276 2         4 push @remaining, $argv->[$i];
277 2         6 next;
278              
279             }
280             }
281              
282             RETURN:
283 39         108 splice @$argv, 0, ~~@$argv, @remaining; # replace with remaining elements
284 39         858 return $success;
285             }
286              
287             sub GetOptions {
288 0     0 0 0 GetOptionsFromArray(\@ARGV, @_);
289             }
290              
291             # IFBUILT
292             sub parse_getopt_long_opt_spec {
293 55     55 0 87 my $optspec = shift;
294 55 50       125 return {is_arg=>1, dash_prefix=>'', opts=>[]}
295             if $optspec eq '<>';
296 55 50       718 $optspec =~ qr/\A
297             (?P-{0,2})
298             (?P[A-Za-z0-9_][A-Za-z0-9_-]*)
299             (?P (?: \| (?:[^:|!+=:-][^:|!+=:]*) )*)?
300             (?:
301             (?P!) |
302             (?P\+) |
303             (?:
304             =
305             (?P[siof])
306             (?P|[%@])?
307             (?:
308             \{
309             (?: (?P\d+), )?
310             (?P\d+)
311             \}
312             )?
313             ) |
314             (?:
315             :
316             (?P[siof])
317             (?P|[%@])
318             ) |
319             (?:
320             :
321             (?P\d+)
322             (?P|[%@])
323             )
324             (?:
325             :
326             (?P\+)
327             (?P|[%@])
328             )
329             )?
330             \z/x
331             or return undef;
332 1     1   509 my %res = %+;
  1         365  
  1         216  
  55         963  
333              
334 55 100       250 if ($res{aliases}) {
335 8         15 my @als;
336 8         25 for my $al (split /\|/, $res{aliases}) {
337 16 100       32 next unless length $al;
338 8 50       17 next if $al eq $res{name};
339 8 50       20 next if grep {$_ eq $al} @als;
  0         0  
340 8         19 push @als, $al;
341             }
342 8         25 $res{opts} = [$res{name}, @als];
343             } else {
344 47         115 $res{opts} = [$res{name}];
345             }
346 55         96 delete $res{name};
347 55         80 delete $res{aliases};
348              
349 55 100       116 $res{is_neg} = 1 if $res{is_neg};
350 55 100       106 $res{is_inc} = 1 if $res{is_inc};
351              
352 55         148 \%res;
353             }
354              
355             # END IFBUILT
356             # IFUNBUILT
357             # require Getopt::Long::Util; *parse_getopt_long_opt_spec = \&Getopt::Long::Util::parse_getopt_long_opt_spec;
358             # END IFUNBUILT
359              
360             package Getopt::Long::Less::Callback;
361              
362             sub new {
363 34     34   51 my $class = shift;
364 34         112 bless {@_}, $class;
365             }
366              
367             sub name {
368 33     33   116 shift->{name};
369             }
370              
371             1;
372             # ABSTRACT: Like Getopt::Long, but with less features
373              
374             __END__