File Coverage

blib/lib/Perinci/Sub/GetArgs/Argv.pm
Criterion Covered Total %
statement 451 475 94.9
branch 195 238 81.9
condition 99 132 75.0
subroutine 30 31 96.7
pod 2 2 100.0
total 777 878 88.5


line stmt bran cond sub pod time code
1              
2             use 5.010001;
3 3     3   186706 use strict;
  3         36  
4 3     3   14 use warnings;
  3         6  
  3         50  
5 3     3   11 #use Log::Any '$log';
  3         5  
  3         67  
6              
7             use Data::Sah::Normalize qw(normalize_schema);
8 3     3   797 use Data::Sah::Util::Type qw(is_type is_simple);
  3         2510  
  3         180  
9 3     3   1179 use Getopt::Long::Negate::EN qw(negations_for_option);
  3         2754  
  3         178  
10 3     3   1169 use Getopt::Long::Util qw(parse_getopt_long_opt_spec);
  3         2136  
  3         146  
11 3     3   1219 use List::Util qw(first);
  3         7032  
  3         169  
12 3     3   19 use Perinci::Sub::GetArgs::Array qw(get_args_from_array);
  3         5  
  3         217  
13 3     3   1214 use Perinci::Sub::Util qw(err);
  3         2998  
  3         154  
14 3     3   1260  
  3         5925  
  3         227  
15             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
16             our $DATE = '2022-03-27'; # DATE
17             our $DIST = 'Perinci-Sub-GetArgs-Argv'; # DIST
18             our $VERSION = '0.849'; # VERSION
19              
20             use Exporter;
21 3     3   18 our @ISA = qw(Exporter);
  3         5  
  3         565  
22             our @EXPORT_OK = qw(
23             gen_getopt_long_spec_from_meta
24             get_args_from_argv
25             );
26              
27             our %SPEC;
28              
29             $SPEC{':package'} = {
30             v => 1.1,
31             summary => 'Get subroutine arguments from command line arguments (@ARGV)',
32             };
33              
34             # retun ($success?, $errmsg, $res)
35             my $str = shift;
36              
37 8     8   12 state $json = do {
38             require JSON::PP;
39 8         13 JSON::PP->new->allow_nonref;
40 1         593 };
41 1         11636  
42             # to rid of those JSON::PP::Boolean objects which currently choke
43             # Data::Sah-generated validator code. in the future Data::Sah can be
44             # modified to handle those, or we use a fork of JSON::PP which doesn't
45             # produce those in the first place (probably only when performance is
46             # critical).
47             state $cleanser = do {
48             if (eval { require Data::Clean::FromJSON; 1 }) {
49 8         47 Data::Clean::FromJSON->get_cleanser;
50 1 50       2 } else {
  1         355  
  1         4374  
51 1         6 undef;
52             }
53 0         0 };
54              
55             my $res;
56             eval { $res = $json->decode($str); $cleanser->clean_in_place($res) if $cleanser };
57 8         1473 my $e = $@;
58 8 50       12 return (!$e, $e, $res);
  8         23  
  4         561  
59 8         1183 }
60 8         26  
61             no warnings 'once';
62              
63             state $yaml_xs_available = do {
64 3     3   19 if (eval { require YAML::XS; 1 }) {
  3         5  
  3         12485  
65             1;
66 5     5   8 } else {
67 1 50       2 require YAML::Old;
  1         5  
  1         3  
68 1         4 0;
69             }
70 0         0 };
71 0         0  
72             my $str = shift;
73              
74             #local $YAML::Syck::ImplicitTyping = 1;
75 5         7 my $res;
76             eval {
77             if ($yaml_xs_available) {
78 5         8 $res = YAML::XS::Load($str);
79 5         6 } else {
80 5 50       10 # YAML::Old is too strict, it requires "--- " header and newline
81 5         207 # ending
82             $str = "--- $str" unless $str =~ /\A--- /;
83             $str .= "\n" unless $str =~ /\n\z/;
84             $res = YAML::Old::Load($str);
85 0 0       0 }
86 0 0       0 };
87 0         0 my $e = $@;
88             return (!$e, $e, $res);
89             }
90 5         17  
91 5         23 my $opt = shift;
92             $opt =~ s/[^A-Za-z0-9-]+/-/g; # foo.bar_baz becomes --foo-bar-baz
93             $opt;
94             }
95 244     244   323  
96 244         522 # this subroutine checks whether a schema mentions a coercion rule from simple
97 244         421 # types (e.g. 'str_comma_sep', etc).
98             my $nsch = shift;
99             my $clset = $nsch->[1] or return 0;
100             my $rules = $clset->{'x.perl.coerce_rules'} // $clset->{'x.coerce_rules'}
101             or return 0;
102             for my $rule (@$rules) {
103 192     192   3112 next unless $rule =~ /\A([^_]+)_/;
104 192 50       350 return 1 if is_simple($1);
105 192 100 66     751 }
106             0;
107 2         4 }
108 2 50       9  
109 2 50       4 my $nsch = shift;
110             is_simple($nsch) || _is_coercible_from_simple($nsch);
111 0         0 }
112              
113             # this routine's job is to avoid using Data::Sah::Resolve unless it needs to, to
114             # reduce startup overhead
115 561     561   733 my $nsch = shift;
116 561 100       822  
117             my $is_simple = 0;
118             my $is_array_of_simple = 0;
119             my $is_hash_of_simple = 0;
120             my $eltype;
121              
122 462     462   74553 my $type = $nsch->[0];
123             my $clset = $nsch->[1];
124 462         555  
125 462         519 {
126 462         540 # if not known as builtin type, then resolve it first
127 462         495 unless (is_type($nsch)) {
128             require Data::Sah::Resolve;
129 462         629 my $res = Data::Sah::Resolve::resolve_schema(
130 462         573 {schema_is_normalized=>1}, $nsch);
131             $type = $res->{type};
132             $clset = $res->{clsets_after_type}[0] // {};
133             }
134 462 100       521  
  462         860  
135 1         406 $is_simple = _is_simple_or_coercible_from_simple([$type, $clset]);
136 1         1139 last if $is_simple;
137              
138 1         16211 if ($type eq 'array') {
139 1   50     9 my $elnsch = $clset->{of} // $clset->{each_elem};
140             last unless $elnsch;
141             $elnsch = normalize_schema($elnsch);
142 462         7458 $eltype = $elnsch->[0];
143 462 100       5246  
144             # if not known as builtin type, then resolve it first
145 188 100       320 unless (is_type($elnsch)) {
146 104   66     240 require Data::Sah::Resolve;
147 104 100       192 my $res = Data::Sah::Resolve::resolve_schema(
148 64         124 {schema_is_normalized=>1}, $elnsch);
149 64         2167 $elnsch = [$res->{type}, $res->{clsets_after_type}[0] // {}]; # XXX we only take the first clause set
150             $eltype = $res->{type};
151             }
152 64 100       123  
153 1         18 $is_array_of_simple = _is_simple_or_coercible_from_simple($elnsch);
154 1         5 last;
155             }
156 1   50     232  
157 1         4 if ($type eq 'hash') {
158             my $elnsch = $clset->{of} // $clset->{each_value} // $clset->{each_elem};
159             last unless $elnsch;
160 64         957 $elnsch = normalize_schema($elnsch);
161 64         1061 $eltype = $elnsch->[0];
162              
163             # if not known as builtin type, then resolve it first
164 84 100       132 unless (is_type($elnsch)) {
165 83   66     237 require Data::Sah::Resolve;
      33        
166 83 100       145 my $res = Data::Sah::Resolve::resolve_schema(
167 35         64 {schema_is_normalized=>1}, $elnsch);
168 35         482 $elnsch = [$res->{type}, $res->{clsets_after_type}[0] // {}]; # XXX we only take the first clause set
169             $eltype = $res->{type};
170             }
171 35 100       64  
172 1         18 $is_hash_of_simple = _is_simple_or_coercible_from_simple($elnsch);
173 1         5 last;
174             }
175 1   50     227 }
176 1         6  
177             #{ no warnings 'uninitialized'; say "D:$nsch->[0]: is_simple=<$is_simple>, is_array_of_simple=<$is_array_of_simple>, is_hash_of_simple=<$is_hash_of_simple>, type=<$type>, eltype=<$eltype>" };
178             ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $clset, $eltype);
179 35         489 }
180 35         565  
181             # return one or more triplets of Getopt::Long option spec, its parsed structure,
182             # and extra stuffs. we do this to avoid having to call
183             # parse_getopt_long_opt_spec().
184             my ($opt, $schema, $arg_spec) = @_;
185 462         1257 my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $clset, $eltype) =
186             _is_simple_or_array_of_simple_or_hash_of_simple($schema);
187              
188             my (@opts, @types, @isaos, @ishos);
189              
190             if ($is_array_of_simple || $is_hash_of_simple) {
191             my $singular_opt;
192 234     234   377 if ($arg_spec && $arg_spec->{'x.name.is_plural'}) {
193 234         339 if ($arg_spec->{'x.name.singular'}) {
194             $singular_opt = _arg2opt($arg_spec->{'x.name.singular'});
195             } else {
196 234         360 require Lingua::EN::PluralToSingular;
197             $singular_opt = Lingua::EN::PluralToSingular::to_singular($opt);
198 234 100 100     606 }
199 54         69 } else {
200 54 100 100     151 $singular_opt = $opt;
201 2 100       4 }
202 1         3 push @opts , $singular_opt;
203             push @types, $eltype;
204 1         1006 push @isaos, $is_array_of_simple ? 1:0;
205 1         1682 push @ishos, $is_hash_of_simple ? 1:0;
206             }
207              
208 52         73 if ($is_simple || !@opts) {
209             push @opts , $opt;
210 54         109 push @types, $type;
211 54         65 push @isaos, 0;
212 54 100       95 push @ishos, 0;
213 54 100       86 }
214              
215             my @res;
216 234 100 100     560  
217 180         277 for my $i (0..$#opts) {
218 180         217 my $opt = $opts[$i];
219 180         219 my $type = $types[$i];
220 180         216 my $isaos = $isaos[$i];
221             my $ishos = $ishos[$i];
222              
223 234         300 if ($type eq 'bool') {
224             if (length $opt == 1) {
225 234         492 # single-letter option like -b doesn't get --nob.
226 234         315 push @res, ($opt, {opts=>[$opt]}), undef;
227 234         282 } elsif ($clset->{is} || $clset->{is_true}) {
228 234         282 # an always-true bool ('true' or [bool => {is=>1}] or
229 234         282 # [bool=>{is_true=>1}] also means it's a flag and should not get
230             # --nofoo.
231 234 100       423 push @res, ($opt, {opts=>[$opt]}), undef;
    100          
232 22 100 66     110 } elsif ((defined $clset->{is} && !$clset->{is}) ||
    100 33        
    100 66        
      33        
233             (defined $clset->{is_true} && !$clset->{is_true})) {
234 4         14 # an always-false bool ('false' or [bool => {is=>0}] or
235             # [bool=>{is_true=>0}] also means it's a flag and should only be
236             # getting --nofoo.
237             for (negations_for_option($opt)) {
238             push @res, $_, {opts=>[$_]}, {is_neg=>1, pos_opts=>[$opt]};
239 2         9 }
240             } else {
241             # a regular bool gets --foo as well as --nofoo
242             my @negs = negations_for_option($opt);
243             push @res, $opt, {opts=>[$opt]}, {is_neg=>0, neg_opts=>\@negs};
244             for (@negs) {
245 1         4 push @res, $_, {opts=>[$_]}, {is_neg=>1, pos_opts=>[$opt]};
246 2         37 }
247             }
248             } elsif ($type eq 'buf') {
249             push @res, (
250 15         39 "$opt=s", {opts=>[$opt], desttype=>"", type=>"s"}, undef,
251 15         207 "$opt-base64=s", {opts=>["$opt-base64"], desttype=>"", type=>"s"}, {is_base64=>1},
252 15         31 );
253 29         139 } else {
254             my $t = ($type eq 'int' ? 's' : $type eq 'float' ? 's' : 's') .
255             ($isaos ? '@' : $ishos ? '%' : '');
256             push @res, ("$opt=$t", {opts=>[$opt], desttype=>"", type=>$t}, undef);
257 3         36 }
258             }
259              
260             @res;
261             }
262 209 100       522  
    100          
    100          
    100          
263             my %args = @_;
264 209         841  
265             my $argprefix = $args{argprefix};
266             my $parent_args = $args{parent_args};
267             my $meta = $args{meta};
268 234         670 my $seen_opts = $args{seen_opts};
269             my $seen_common_opts = $args{seen_common_opts};
270             my $seen_func_opts = $args{seen_func_opts};
271             my $rargs = $args{rargs};
272 81     81   284 my $go_spec = $args{go_spec};
273             my $specmeta = $args{specmeta};
274 81         114  
275 81         100 my $args_prop = $meta->{args} // {};
276 81         95  
277 81         115 for my $arg (keys %$args_prop) {
278 81         91 my $fqarg = "$argprefix$arg";
279 81         100 my $optlabel = "arg=$arg".($fqarg ne $arg ? ", fqarg=$fqarg":""); # written to %$seen_opts values
280 81         92 my $arg_spec = $args_prop->{$arg};
281 81         95 next if grep { $_ eq 'hidden' || $_ eq 'hidden-cli' }
282 81         93 @{ $arg_spec->{tags} // [] };
283             my $sch = $arg_spec->{schema} // ['any', {}];
284 81   50     170 my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $clset, $eltype) =
285             _is_simple_or_array_of_simple_or_hash_of_simple($sch);
286 81         195  
287 208         383 # XXX normalization of 'of' clause should've been handled by sah itself
288 208 100       434 if ($type eq 'array' && $clset->{of}) {
289 208         271 $clset->{of} = normalize_schema($clset->{of});
290 0 0       0 }
291 208 50 50     236 my $opt = _arg2opt($fqarg);
  208         694  
292 208   50     423 if ($seen_opts->{$opt}) {
293 208         354 my $i = 1;
294             my $opt2;
295             while (1) {
296             $opt2 = "$opt-arg" . ($i > 1 ? $i : '');
297 208 100 100     484 last unless $seen_opts->{$opt2};
298 25         85 $i++;
299             }
300 208         621 $opt = $opt2;
301 208 100       389 }
302 3         5  
303 3         5 my $stash = {};
304 3         4  
305 3 50       23 # why we use coderefs here? due to Getopt::Long's behavior. when
306 3 50       9 # @ARGV=qw() and go_spec is ('foo=s' => \$opts{foo}) then %opts will
307 0         0 # become (foo=>undef). but if go_spec is ('foo=s' => sub { $opts{foo} =
308             # $_[1] }) then %opts will become (), which is what we prefer, so we can
309 3         5 # later differentiate "unspecified" (exists($opts{foo}) == false) and
310             # "specified as undef" (exists($opts{foo}) == true but
311             # defined($opts{foo}) == false).
312 208         270  
313             my $handler = sub {
314             my ($val, $val_set);
315              
316             # how many times have been called for this argument?
317             my $num_called = ++$stash->{called}{$arg};
318              
319             # hashify rargs till the end of the handler scope if it happens to
320             # be an array (this is the case when we want to fill values using
321             # element_meta).
322             my $rargs = do {
323 82     82   19010 if (ref($rargs) eq 'ARRAY') {
324             $rargs->[$num_called-1] //= {};
325             $rargs->[$num_called-1];
326 82         183 } else {
327             $rargs;
328             }
329             };
330              
331 82         94 if ($is_simple) {
332 82 100       153 $val_set = 1; $val = $_[1];
333 5   100     22 $rargs->{$arg} = $val;
334 5         8 } elsif ($is_array_of_simple) {
335             $rargs->{$arg} //= [];
336 77         117 $val_set = 1; $val = $_[1];
337             push @{ $rargs->{$arg} }, $val;
338             } elsif ($is_hash_of_simple) {
339             $rargs->{$arg} //= {};
340 82 100       157 $val_set = 1; $val = $_[2];
    100          
    100          
341 54         67 $rargs->{$arg}{$_[1]} = $val;
  54         80  
342 54         88 } else {
343             {
344 16   100     51 my ($success, $e, $decoded);
345 16         19 ($success, $e, $decoded) = _parse_json($_[1]);
  16         24  
346 16         21 if ($success) {
  16         30  
347             $val_set = 1; $val = $decoded;
348 7   100     27 $rargs->{$arg} = $val;
349 7         10 last;
  7         10  
350 7         14 }
351             ($success, $e, $decoded) = _parse_yaml($_[1]);
352             if ($success) {
353 5         7 $val_set = 1; $val = $decoded;
  5         6  
354 5         12 $rargs->{$arg} = $val;
355 5 100       11 last;
356 3         4 }
  3         4  
357 3         6 die "Invalid YAML/JSON in arg '$fqarg'";
358 3         4 }
359             }
360 2         6 if ($val_set && $arg_spec->{cmdline_on_getopt}) {
361 2 100       7 $arg_spec->{cmdline_on_getopt}->(
362 1         1 arg=>$arg, fqarg=>$fqarg, value=>$val, args=>$rargs,
  1         2  
363 1         2 opt=>$opt,
364 1         2 );
365             }
366 1         7 }; # handler
367              
368             my @triplets = _opt2ospec($opt, $sch, $arg_spec);
369 81 100 66     337 my $aliases_processed;
370 5         12 while (my ($ospec, $parsed, $extra) = splice @triplets, 0, 3) {
371             my $optlabel = $optlabel . ", spec=$ospec"; # note: redefine
372             $extra //= {};
373             if ($extra->{is_neg}) {
374             $go_spec->{$ospec} = sub { $handler->($_[0], 0) };
375 208         786 } elsif (defined $extra->{is_neg}) {
376             $go_spec->{$ospec} = sub { $handler->($_[0], 1) };
377 208         385 } elsif ($extra->{is_base64}) {
378 208         281 $go_spec->{$ospec} = sub {
379 208         508 require MIME::Base64;
380 241         448 my $decoded = MIME::Base64::decode($_[1]);
381 241   100     703 $handler->($_[0], $decoded);
382 241 100       526 };
    100          
    100          
383 31     2   89 } else {
  2         783  
384             $go_spec->{$ospec} = $handler;
385 15     2   48 }
  2         392  
386              
387             $specmeta->{$ospec} = {arg=>$arg, fqarg=>$fqarg, parsed=>$parsed, %$extra};
388 1     1   785 for (@{ $parsed->{opts} }) {
389 1         613 $seen_opts->{$_} = $optlabel;
390 1         4 $seen_func_opts->{$_} = $fqarg;
391 3         20 }
392              
393 192         322 if ($parent_args->{per_arg_json} && !$is_simple) {
394             my $jopt = "$opt-json";
395             if ($seen_opts->{$jopt}) {
396 241         773 warn "Clash of option $jopt ($optlabel) vs existing ($seen_opts->{$jopt}), not added";
397 241         332 } else {
  241         432  
398 241         371 my $jospec = "$jopt=s";
399 241         722 my $parsed = {type=>"s", opts=>[$jopt]};
400             $go_spec->{$jospec} = sub {
401             my ($success, $e, $decoded);
402 241 100 100     481 ($success, $e, $decoded) = _parse_json($_[1]);
403 8         18 if ($success) {
404 8 50       22 $rargs->{$arg} = $decoded;
405 0         0 } else {
406             die "Invalid JSON in option --$jopt: $_[1]: $e";
407 8         22 }
408 8         20 };
409             $specmeta->{$jospec} = {arg=>$arg, fqarg=>$fqarg, is_json=>1, parsed=>$parsed, %$extra};
410 1     1   246 $seen_opts->{$jopt} = $optlabel;
411 1         4 $seen_func_opts->{$jopt} = $fqarg;
412 1 50       4 }
413 1         3 }
414             if ($parent_args->{per_arg_yaml} && !$is_simple) {
415 0         0 my $yopt = "$opt-yaml";
416             if ($seen_opts->{$yopt}) {
417 8         33 warn "Clash of option: $yopt ($optlabel) vs existing ($seen_opts->{$yopt}), not added";
418 8         27 } else {
419 8         17 my $yospec = "$yopt=s";
420 8         16 my $parsed = {type=>"s", opts=>[$yopt]};
421             $go_spec->{$yospec} = sub {
422             my ($success, $e, $decoded);
423 241 100 100     442 ($success, $e, $decoded) = _parse_yaml($_[1]);
424 8         18 if ($success) {
425 8 50       16 $rargs->{$arg} = $decoded;
426 0         0 } else {
427             die "Invalid YAML in option --$yopt: $_[1]: $e";
428 8         15 }
429 8         20 };
430             $specmeta->{$yospec} = {arg=>$arg, fqarg=>$fqarg, is_yaml=>1, parsed=>$parsed, %$extra};
431 1     1   264 $seen_opts->{$yopt} = $optlabel;
432 1         3 $seen_func_opts->{$yopt} = $fqarg;
433 1 50       4 }
434 1         4 }
435              
436 0         0 # parse argv_aliases
437             if ($arg_spec->{cmdline_aliases} && !$aliases_processed++) {
438 8         37 for my $al (keys %{$arg_spec->{cmdline_aliases}}) {
439 8         26 my $alspec = $arg_spec->{cmdline_aliases}{$al};
440 8         17 my $alsch = $alspec->{schema} //
441 8         15 $alspec->{is_flag} ? [bool=>{req=>1,is=>1}] : $sch;
442             my $altype = $alsch->[0];
443             my $alopt = _arg2opt("$argprefix$al");
444             if ($seen_opts->{$alopt}) {
445             warn "Clash of cmdline_alias option $al ($optlabel) vs existing ($seen_opts->{$alopt})";
446 241 100 100     485 next;
447 31         41 }
  31         78  
448 35         56 my $alcode = $alspec->{code};
449             my $alospec;
450 35 100 66     112 my $parsed;
451 35         55 if ($alcode && $alsch->[0] eq 'bool') {
452 35         78 # bool --alias doesn't get --noalias if has code
453 35 50       72 $alospec = $alopt; # instead of "$alopt!"
454 0         0 $parsed = {opts=>[$alopt]};
455 0         0 } else {
456             ($alospec, $parsed) = _opt2ospec($alopt, $alsch);
457 35         47 }
458 35         52  
459             if ($alcode) {
460 35 100 100     82 if ($alcode eq 'CODE') {
461             if ($parent_args->{ignore_converted_code}) {
462 9         14 $alcode = sub {};
463 9         25 } else {
464             return [
465 26         46 501,
466             join("",
467             "Code in cmdline_aliases for arg $fqarg ",
468 35 100       60 "got converted into string, probably ",
469 12 100       32 "because of JSON/YAML transport"),
470 3 100       8 ];
471 1     1   3 }
472             }
473             # alias handler
474 2         17 $go_spec->{$alospec} = sub {
475              
476             # do the same like in arg handler
477             my $num_called = ++$stash->{called}{$arg};
478             my $rargs = do {
479             if (ref($rargs) eq 'ARRAY') {
480             $rargs->[$num_called-1] //= {};
481             $rargs->[$num_called-1];
482             } else {
483             $rargs;
484             }
485             };
486 3     3   1041  
487 3         5 $alcode->($rargs, $_[1]);
488 3 50       10 };
489 0   0     0 } else {
490 0         0 $go_spec->{$alospec} = $handler;
491             }
492 3         6 $specmeta->{$alospec} = {
493             (summary => $alspec->{summary}) x !!defined($alspec->{summary}),
494             alias => $al,
495             is_alias => 1,
496 3         8 alias_for => $ospec,
497 10         41 arg => $arg,
498             fqarg => $fqarg,
499 23         43 is_code => $alcode ? 1:0,
500             parsed => $parsed,
501             %$extra,
502 33 100       183 };
503             push @{$specmeta->{$ospec}{($alcode ? '':'non').'code_aliases'}},
504             $alospec;
505             $seen_opts->{$alopt} = $optlabel;
506             $seen_func_opts->{$alopt} = $fqarg;
507             }
508             } # cmdline_aliases
509              
510             # submetadata
511             if ($arg_spec->{meta}) {
512 33 100       47 $rargs->{$arg} = {};
  33         121  
513             my $res = _args2opts(
514 33         66 %args,
515 33         75 argprefix => "$argprefix$arg\::",
516             meta => $arg_spec->{meta},
517             rargs => $rargs->{$arg},
518             );
519             return $res if $res;
520 239 100       385 }
521 2         10  
522             # element submetadata
523             if ($arg_spec->{element_meta}) {
524             $rargs->{$arg} = [];
525             my $res = _args2opts(
526 2         27 %args,
527             argprefix => "$argprefix$arg\::",
528 2 50       13 meta => $arg_spec->{element_meta},
529             rargs => $rargs->{$arg},
530             );
531             return $res if $res;
532 239 100       936 }
533 3         9 } # for ospec triplet
534              
535             } # for arg
536              
537             undef;
538 3         75 }
539              
540 3 50       25 $SPEC{gen_getopt_long_spec_from_meta} = {
541             v => 1.1,
542             summary => 'Generate Getopt::Long spec from Rinci function metadata',
543             description => <<'_',
544              
545             This routine will produce a <pm:Getopt::Long> specification from Rinci function
546 79         267 metadata, as well as some more data structure in the result metadata to help
547             producing a command-line help/usage message.
548              
549             Function arguments will be mapped to command-line options with the same name,
550             with non-alphanumeric characters changed to `-` (`-` is preferred over `_`
551             because it lets user avoid pressing Shift on popular keyboards). For example:
552             `file_size` becomes `file-size`, `file_size.max` becomes `file-size-max`. If
553             function argument option name clashes with command-line option or another
554             existing option, it will be renamed to `NAME-arg` (or `NAME-arg2` and so on).
555             For example: `help` will become `help-arg` (if `common_opts` contains `help`,
556             that is).
557              
558             Each command-line alias (`cmdline_aliases` property) in the argument
559             specification will also be added as command-line option, except if it clashes
560             with an existing option, in which case this function will warn and skip adding
561             the alias. For more information about `cmdline_aliases`, see `Rinci::function`.
562              
563             For arguments with type of `bool`, Getopt::Long will by default also
564             automatically recognize `--noNAME` or `--no-NAME` in addition to `--name`. So
565             this function will also check those names for clashes.
566              
567             For arguments with type array of simple scalar, `--NAME` can be specified more
568             than once to append to the array.
569              
570             If `per_arg_json` setting is active, and argument's schema is not a "required
571             simple scalar" (e.g. an array, or a nullable string), then `--NAME-json` will
572             also be added to let users input undef (through `--NAME-json null`) or a
573             non-scalar value (e.g. `--NAME-json '[1,2,3]'`). If this name conflicts with
574             another existing option, a warning will be displayed and the option will not be
575             added.
576              
577             If `per_arg_yaml` setting is active, and argument's schema is not a "required
578             simple scalar" (e.g. an array, or a nullable string), then `--NAME-yaml` will
579             also be added to let users input undef (through `--NAME-yaml '~'`) or a
580             non-scalar value (e.g. `--NAME-yaml '[foo, bar]'`). If this name conflicts with
581             another existing option, a warning will be displayed and the option will not be
582             added. YAML can express a larger set of values, e.g. binary data, circular
583             references, etc.
584              
585             Will produce a hash (Getopt::Long spec), with `func.specmeta`, `func.opts`,
586             `func.common_opts`, `func.func_opts` that contain extra information
587             (`func.specmeta` is a hash of getopt spec name and a hash of extra information
588             while `func.*opts` lists all used option names).
589              
590             _
591             args => {
592             meta => {
593             summary => 'Rinci function metadata',
594             schema => 'hash*',
595             req => 1,
596             },
597             meta_is_normalized => {
598             schema => 'bool*',
599             },
600             args => {
601             summary => 'Reference to hash which will store the result',
602             schema => 'hash*',
603             },
604             common_opts => {
605             summary => 'Common options',
606             description => <<'_',
607              
608             A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
609             option specification), `handler` (Getopt::Long handler). Will be passed to
610             `get_args_from_argv()`. Example:
611              
612             {
613             help => {
614             getopt => 'help|h|?',
615             handler => sub { ... },
616             summary => 'Display help and exit',
617             },
618             version => {
619             getopt => 'version|v',
620             handler => sub { ... },
621             summary => 'Display version and exit',
622             },
623             }
624              
625             _
626             schema => ['hash*'],
627             },
628             per_arg_json => {
629             summary => 'Whether to add --NAME-json for non-simple arguments',
630             schema => 'bool',
631             default => 0,
632             description => <<'_',
633              
634             Will also interpret command-line arguments as JSON if assigned to function
635             arguments, if arguments' schema is not simple scalar.
636              
637             _
638             },
639             per_arg_yaml => {
640             summary => 'Whether to add --NAME-yaml for non-simple arguments',
641             schema => 'bool',
642             default => 0,
643             description => <<'_',
644              
645             Will also interpret command-line arguments as YAML if assigned to function
646             arguments, if arguments' schema is not simple scalar.
647              
648             _
649             },
650             ignore_converted_code => {
651             summary => 'Whether to ignore coderefs converted to string',
652             schema => 'bool',
653             default => 0,
654             description => <<'_',
655              
656             Across network through JSON encoding, coderef in metadata (e.g. in
657             `cmdline_aliases` property) usually gets converted to string `CODE`. In some
658             cases, like for tab completion, this is pretty harmless so you can turn this
659             option on. For example, in the case of `cmdline_aliases`, the effect is just
660             that command-line aliases code are not getting executed, but this is usually
661             okay.
662              
663             _
664             },
665             },
666             };
667             my %fargs = @_;
668              
669             my $meta = $fargs{meta} or return [400, "Please specify meta"];
670             unless ($fargs{meta_is_normalized}) {
671             require Perinci::Sub::Normalize;
672             $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
673             }
674             my $co = $fargs{common_opts} // {};
675             my $per_arg_yaml = $fargs{per_arg_yaml} // 0;
676             my $per_arg_json = $fargs{per_arg_json} // 0;
677 76     76 1 367 my $ignore_converted_code = $fargs{ignore_converted_code};
678             my $rargs = $fargs{args} // {};
679 76 50       158  
680 76 100       135 my %go_spec;
681 1         385 my %specmeta; # key = option spec, val = hash of extra info
682 1         893 my %seen_opts;
683             my %seen_common_opts;
684 76   50     3067 my %seen_func_opts;
685 76   50     142  
686 76   50     127 for my $k (keys %$co) {
687 76         86 my $v = $co->{$k};
688 76   100     159 my $ospec = $v->{getopt};
689             my $handler = $v->{handler};
690 76         245 my $res = parse_getopt_long_opt_spec($ospec)
691             or return [400, "Can't parse common opt spec '$ospec'"];
692 76         0 $go_spec{$ospec} = $handler;
693 76         0 $specmeta{$ospec} = {common_opt=>$k, arg=>undef, parsed=>$res};
694 76         0 for (@{ $res->{opts} }) {
695             return [412, "Clash of common opt '$_' ($seen_opts{$_})"] if $seen_opts{$_};
696 76         160 $seen_opts{$_} = "common option $k";
697 9         16 $seen_common_opts{$_} = $ospec;
698 9         26 if ($res->{is_neg}) {
699 9         11 $seen_opts{"no$_"} = "common option $k, negative form";
700 9 50       39 $seen_common_opts{"no$_"} = $ospec;
701             $seen_opts{"no-$_"} = "common option $k, negative form";
702 9         417 $seen_common_opts{"no-$_"} = $ospec;
703 9         23 }
704 9         13 }
  9         19  
705 12 50       19 }
706 12         27  
707 12         20 my $res = _args2opts(
708 12 100       28 argprefix => "",
709 1         4 parent_args => \%fargs,
710 1         3 meta => $meta,
711 1         3 seen_opts => \%seen_opts,
712 1         2 seen_common_opts => \%seen_common_opts,
713             seen_func_opts => \%seen_func_opts,
714             rargs => $rargs,
715             go_spec => \%go_spec,
716             specmeta => \%specmeta,
717 76         196 );
718             return $res if $res;
719              
720             my $opts = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_opts)];
721             my $common_opts = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_common_opts)];
722             my $func_opts = [sort(map {length($_)>1 ? "--$_":"-$_"} keys %seen_func_opts)];
723             my $opts_by_common = {};
724             for my $k (keys %$co) {
725             my $v = $co->{$k};
726             my $ospec = $v->{getopt};
727             my @opts;
728 76 100       183 for (keys %seen_common_opts) {
729             next unless $seen_common_opts{$_} eq $ospec;
730 74 100       189 push @opts, (length($_)>1 ? "--$_":"-$_");
  302         802  
731 74 100       179 }
  14         33  
732 74 100       170 $opts_by_common->{$ospec} = [sort @opts];
  288         589  
733 74         131 }
734 74         130  
735 9         15 my $opts_by_arg = {};
736 9         13 for (keys %seen_func_opts) {
737 9         11 my $fqarg = $seen_func_opts{$_};
738 9         17 push @{ $opts_by_arg->{$fqarg} }, length($_)>1 ? "--$_":"-$_";
739 58 100       92 }
740 14 100       30 for (keys %$opts_by_arg) {
741             $opts_by_arg->{$_} = [sort @{ $opts_by_arg->{$_} }];
742 9         26 }
743              
744             [200, "OK", \%go_spec,
745 74         99 {
746 74         132 "func.specmeta" => \%specmeta,
747 288         393 "func.opts" => $opts,
748 288 100       307 "func.common_opts" => $common_opts,
  288         711  
749             "func.func_opts" => $func_opts,
750 74         164 "func.opts_by_arg" => $opts_by_arg,
751 206         236 "func.opts_by_common" => $opts_by_common,
  206         459  
752             }];
753             }
754 74         602  
755             $SPEC{get_args_from_argv} = {
756             v => 1.1,
757             summary => 'Get subroutine arguments (%args) from command-line arguments '.
758             '(@ARGV)',
759             description => <<'_',
760              
761             Using information in Rinci function metadata's `args` property, parse command
762             line arguments `@argv` into hash `%args`, suitable for passing into subroutines.
763              
764             Currently uses <pm:Getopt::Long>'s `GetOptions` to do the parsing.
765              
766             As with GetOptions, this function modifies its `argv` argument, so you might
767             want to copy the original `argv` first (or pass a copy instead) if you want to
768             preserve the original.
769              
770             See also: gen_getopt_long_spec_from_meta() which is the routine that generates
771             the specification.
772              
773             _
774             args => {
775             argv => {
776             schema => ['array*' => {
777             of => 'str*',
778             }],
779             description => 'If not specified, defaults to @ARGV',
780             },
781             args => {
782             summary => 'Specify input args, with some arguments preset',
783             schema => ['hash'],
784             },
785             meta => {
786             schema => ['hash*' => {}],
787             req => 1,
788             },
789             meta_is_normalized => {
790             summary => 'Can be set to 1 if your metadata is normalized, '.
791             'to avoid duplicate effort',
792             schema => 'bool',
793             default => 0,
794             },
795             strict => {
796             schema => ['bool' => {default=>1}],
797             summary => 'Strict mode',
798             description => <<'_',
799              
800             If set to 0, will still return parsed argv even if there are parsing errors
801             (reported by Getopt::Long). If set to 1 (the default), will die upon error.
802              
803             Normally you would want to use strict mode, for more error checking. Setting off
804             strict is used by, for example, Perinci::Sub::Complete during completion where
805             the command-line might still be incomplete.
806              
807             Should probably be named `ignore_errors` or `allow_unknown_options`. :-)
808              
809             _
810             },
811             per_arg_yaml => {
812             schema => ['bool' => {default=>0}],
813             summary => 'Whether to recognize --ARGNAME-yaml',
814             description => <<'_',
815              
816             This is useful for example if you want to specify a value which is not
817             expressible from the command-line, like 'undef'.
818              
819             % script.pl --name-yaml '~'
820              
821             See also: per_arg_json. You should enable just one instead of turning on both.
822              
823             _
824             },
825             per_arg_json => {
826             schema => ['bool' => {default=>0}],
827             summary => 'Whether to recognize --ARGNAME-json',
828             description => <<'_',
829              
830             This is useful for example if you want to specify a value which is not
831             expressible from the command-line, like 'undef'.
832              
833             % script.pl --name-json 'null'
834              
835             But every other string will need to be quoted:
836              
837             % script.pl --name-json '"foo"'
838              
839             See also: per_arg_yaml. You should enable just one instead of turning on both.
840              
841             _
842             },
843             common_opts => {
844             summary => 'Common options',
845             description => <<'_',
846              
847             A hash where the values are hashes containing these keys: `getopt` (Getopt::Long
848             option specification), `handler` (Getopt::Long handler). Will be passed to
849             `get_args_from_argv()`. Example:
850              
851             {
852             help => {
853             getopt => 'help|h|?',
854             handler => sub { ... },
855             summary => 'Display help and exit',
856             },
857             version => {
858             getopt => 'version|v',
859             handler => sub { ... },
860             summary => 'Display version and exit',
861             },
862             }
863              
864             _
865             schema => ['hash*'],
866             },
867             allow_extra_elems => {
868             schema => ['bool' => {default=>0}],
869             summary => 'Allow extra/unassigned elements in argv',
870             description => <<'_',
871              
872             If set to 1, then if there are array elements unassigned to one of the
873             arguments, instead of generating an error, this function will just ignore them.
874              
875             This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
876              
877             _
878             },
879             on_missing_required_args => {
880             schema => 'code',
881             summary => 'Execute code when there is missing required args',
882             description => <<'_',
883              
884             This can be used to give a chance to supply argument value from other sources if
885             not specified by command-line options. Perinci::CmdLine, for example, uses this
886             hook to supply value from STDIN or file contents (if argument has `cmdline_src`
887             specification key set).
888              
889             This hook will be called for each missing argument. It will be supplied hash
890             arguments: (arg => $the_missing_argument_name, args =>
891             $the_resulting_args_so_far, spec => $the_arg_spec).
892              
893             The hook can return true if it succeeds in making the missing situation
894             resolved. In this case, this function will not report the argument as missing.
895              
896             _
897             },
898             ignore_converted_code => {
899             summary => 'Whether to ignore coderefs converted to string',
900             schema => 'bool',
901             default => 0,
902             description => <<'_',
903              
904             Across network through JSON encoding, coderef in metadata (e.g. in
905             `cmdline_aliases` property) usually gets converted to string `CODE`. In some
906             cases, like for tab completion, this is harmless so you can turn this option on.
907              
908             _
909             },
910             ggls_res => {
911             summary => 'Full result from gen_getopt_long_spec_from_meta()',
912             schema => 'array*', # XXX envres
913             description => <<'_',
914              
915             If you already call `gen_getopt_long_spec_from_meta()`, you can pass the _full_ enveloped result
916             here, to avoid calculating twice.
917              
918             _
919             tags => ['category:optimization'],
920             },
921             },
922             result => {
923             description => <<'_',
924              
925             Error codes:
926              
927             * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
928              
929             * 500 - failure in GetOptions, meaning argv is not valid according to metadata
930             specification (only if 'strict' mode is enabled).
931              
932             * 501 - coderef in cmdline_aliases got converted into a string, probably because
933             the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
934              
935             _
936             },
937             };
938             require Getopt::Long;
939              
940             my %fargs = @_;
941             my $argv = $fargs{argv} // \@ARGV;
942             my $meta = $fargs{meta} or return [400, "Please specify meta"];
943             unless ($fargs{meta_is_normalized}) {
944             require Perinci::Sub::Normalize;
945             $meta = Perinci::Sub::Normalize::normalize_function_metadata($meta);
946             }
947             my $strict = $fargs{strict} // 1;
948             my $common_opts = $fargs{common_opts} // {};
949 75     75 1 309217 my $per_arg_yaml = $fargs{per_arg_yaml} // 0;
950             my $per_arg_json = $fargs{per_arg_json} // 0;
951 75         8824 my $allow_extra_elems = $fargs{allow_extra_elems} // 0;
952 75   100     179 my $on_missing = $fargs{on_missing_required_args};
953 75 50       164 my $ignore_converted_code = $fargs{ignore_converted_code};
954 75 50       149 #$log->tracef("-> get_args_from_argv(), argv=%s", $argv);
955 75         562  
956 75         1111 # to store the resulting args
957             my $rargs = $fargs{args} // {};
958 75   100     20756  
959 75   100     189 # 1. first we generate Getopt::Long spec
960 75   100     184 my $genres = $fargs{ggls_res} // gen_getopt_long_spec_from_meta(
961 75   100     169 meta => $meta, meta_is_normalized => 1,
962 75   100     178 args => $rargs,
963 75         97 common_opts => $common_opts,
964 75         100 per_arg_json => $per_arg_json,
965             per_arg_yaml => $per_arg_yaml,
966             ignore_converted_code => $ignore_converted_code,
967             );
968 75   100     174 return err($genres->[0], "Can't generate Getopt::Long spec", $genres)
969             if $genres->[0] != 200;
970             my $go_spec = $genres->[2];
971 75   33     206  
972             # 2. then we run GetOptions to fill $rargs from command-line opts
973             #$log->tracef("GetOptions spec: %s", \@go_spec);
974             {
975             local $SIG{__WARN__} = sub{} if !$strict;
976             my $old_go_conf = Getopt::Long::Configure(
977             $strict ? "no_pass_through" : "pass_through",
978             "no_ignore_case", "permute", "no_getopt_compat", "gnu_compat", "bundling");
979 75 100       165 my $res = Getopt::Long::GetOptionsFromArray($argv, %$go_spec);
980             Getopt::Long::Configure($old_go_conf);
981 73         95 unless ($res) {
982             return [500, "GetOptions failed"] if $strict;
983             }
984             }
985              
986 73 100   0   84 # 3. then we try to fill $rargs from remaining command-line arguments (for
  73         126  
987 73 100       209 # args which have 'pos' spec specified)
988              
989             my $args_prop = $meta->{args};
990 73         5468  
991 73         6592 if (@$argv) {
992 73 100       1102 my $res = get_args_from_array(
993 9 50       205 array=>$argv, meta => $meta,
994             meta_is_normalized => 1,
995             allow_extra_elems => $allow_extra_elems,
996             );
997             if ($res->[0] != 200 && $strict) {
998             return err(500, "Get args from array failed", $res);
999             } elsif ($strict && $res->[0] != 200) {
1000 64         118 return err("Can't get args from argv", $res);
1001             } elsif ($res->[0] == 200) {
1002 64 100       118 my $pos_args = $res->[2];
1003 13         38 for my $name (keys %$pos_args) {
1004             my $arg_spec = $args_prop->{$name};
1005             my $val = $pos_args->{$name};
1006             if (exists $rargs->{$name}) {
1007             return [400, "You specified option --$name but also ".
1008 13 100 100     547 "argument #".$arg_spec->{pos}] if $strict;
    50 66        
    100          
1009 2         9 }
1010             my ($is_simple, $is_array_of_simple, $is_hash_of_simple, $type, $clset, $eltype) =
1011 0         0 _is_simple_or_array_of_simple_or_hash_of_simple($arg_spec->{schema});
1012              
1013 10         14 if (($arg_spec->{slurpy} // $arg_spec->{greedy}) && ref($val) eq 'ARRAY' &&
1014 10         25 !$is_array_of_simple && !$is_hash_of_simple) {
1015 11         18 my $i = 0;
1016 11         14 for (@$val) {
1017 11 100       23 TRY_PARSING_AS_JSON_YAML:
1018             {
1019 2 50       71 my ($success, $e, $decoded);
1020             if ($per_arg_json) {
1021             ($success, $e, $decoded) = _parse_json($_);
1022 9         20 if ($success) {
1023             $_ = $decoded;
1024 9 100 66     45 last TRY_PARSING_AS_JSON_YAML;
      66        
      100        
      66        
1025             } else {
1026 1         2 #warn "Failed trying to parse argv #$i as JSON: $e";
1027 1         2 }
1028             }
1029             if ($per_arg_yaml) {
1030 1         2 ($success, $e, $decoded) = _parse_yaml($_);
  1         2  
1031 1 50       2 if ($success) {
1032 1         3 $_ = $decoded;
1033 1 50       4 last TRY_PARSING_AS_JSON_YAML;
1034 0         0 } else {
1035 0         0 #warn "Failed trying to parse argv #$i as YAML: $e";
1036             }
1037             }
1038             }
1039             $i++;
1040 1 50       4 }
1041 1         2 }
1042 1 50       3 if (!($arg_spec->{slurpy} // $arg_spec->{greedy}) && !$is_simple) {
1043 1         2 TRY_PARSING_AS_JSON_YAML:
1044 1         2 {
1045             my ($success, $e, $decoded);
1046             if ($per_arg_json) {
1047             ($success, $e, $decoded) = _parse_json($val);
1048             if ($success) {
1049             $val = $decoded;
1050 1         3 last TRY_PARSING_AS_JSON_YAML;
1051             } else {
1052             #warn "Failed trying to parse argv #$arg_spec->{pos} as JSON: $e";
1053 9 100 66     36 }
      100        
1054             }
1055             if ($per_arg_yaml) {
1056 1         2 ($success, $e, $decoded) = _parse_yaml($val);
  1         3  
1057 1 50       2 if ($success) {
1058 1         4 $val = $decoded;
1059 1 50       5 last TRY_PARSING_AS_JSON_YAML;
1060 0         0 } else {
1061 0         0 #warn "Failed trying to parse argv #$arg_spec->{pos} as YAML: $e";
1062             }
1063             }
1064             }
1065             }
1066 1 50       3 $rargs->{$name} = $val;
1067 1         3 # we still call cmdline_on_getopt for this
1068 1 50       4 if ($arg_spec->{cmdline_on_getopt}) {
1069 1         3 if ($arg_spec->{slurpy} // $arg_spec->{greedy}) {
1070 1         2 $arg_spec->{cmdline_on_getopt}->(
1071             arg=>$name, fqarg=>$name, value=>$_, args=>$rargs,
1072             opt=>undef, # this marks that value is retrieved from cmdline arg
1073             ) for @$val;
1074             } else {
1075             $arg_spec->{cmdline_on_getopt}->(
1076             arg=>$name, fqarg=>$name, value=>$val, args=>$rargs,
1077 9         17 opt=>undef, # this marks that value is retrieved from cmdline arg
1078             );
1079 9 100       29 }
1080 2 50 33     7 }
1081             }
1082             }
1083             }
1084 2         8  
1085             # 4. check missing required args
1086 0         0  
1087             my %missing_args; # value = order
1088             my $i = 0;
1089             for my $arg (sort {
1090             (($args_prop->{$a}{pos}//9999) <=> ($args_prop->{$b}{pos}//9999)) ||
1091             ($a cmp $b) } keys %$args_prop) {
1092             my $arg_spec = $args_prop->{$arg};
1093             if (!exists($rargs->{$arg})) {
1094             next unless $arg_spec->{req};
1095             # give a chance to hook to set missing arg
1096             if ($on_missing) {
1097             next if $on_missing->(arg=>$arg, args=>$rargs, spec=>$arg_spec);
1098 60         91 }
1099 60         74 next if exists $rargs->{$arg};
1100 60         196 $missing_args{$arg} = ++$i;
1101 134 50 100     512 }
      100        
1102             }
1103 149         196  
1104 149 100       260 # 5. check 'deps', currently we only support 'arg' dep type
1105 70 100       162 {
1106             last unless $strict;
1107 5 100       14  
1108 2 100       8 for my $arg (keys %$args_prop) {
1109             my $arg_spec = $args_prop->{$arg};
1110 4 100       23 next unless exists $rargs->{$arg};
1111 3         6 next unless $arg_spec->{deps};
1112             my $dep_arg = $arg_spec->{deps}{arg};
1113             next unless $dep_arg;
1114             return [400, "You specify '$arg', but don't specify '$dep_arg' ".
1115             "(upon which '$arg' depends)"]
1116             unless exists $rargs->{$dep_arg};
1117 60 100       81 }
  60         108  
1118             }
1119 59         110  
1120 147         206 #$log->tracef("<- get_args_from_argv(), args=%s, remaining argv=%s",
1121 147 100       244 # $rargs, $argv);
1122 79 100       141 [200, "OK", $rargs, {
1123 2         4 "func.missing_args" => [sort {$missing_args{$a} <=> $missing_args{$b} } keys %missing_args],
1124 2 50       6 "func.gen_getopt_long_spec_result" => $genres,
1125             }];
1126             }
1127 2 100       29  
1128             1;
1129             # ABSTRACT: Get subroutine arguments from command line arguments (@ARGV)
1130              
1131              
1132             =pod
1133              
1134 59         379 =encoding UTF-8
  0            
1135              
1136             =head1 NAME
1137              
1138             Perinci::Sub::GetArgs::Argv - Get subroutine arguments from command line arguments (@ARGV)
1139              
1140             =head1 VERSION
1141              
1142             This document describes version 0.849 of Perinci::Sub::GetArgs::Argv (from Perl distribution Perinci-Sub-GetArgs-Argv), released on 2022-03-27.
1143              
1144             =head1 SYNOPSIS
1145              
1146             use Perinci::Sub::GetArgs::Argv;
1147              
1148             my $res = get_args_from_argv(argv=>\@ARGV, meta=>$meta, ...);
1149              
1150             =head1 DESCRIPTION
1151              
1152             This module provides C<get_args_from_argv()>, which parses command line
1153             arguments (C<@ARGV>) into subroutine arguments (C<%args>). This module is used
1154             by L<Perinci::CmdLine>. For explanation on how command-line options are
1155             processed, see Perinci::CmdLine's documentation.
1156              
1157             =head1 FUNCTIONS
1158              
1159              
1160             =head2 gen_getopt_long_spec_from_meta
1161              
1162             Usage:
1163              
1164             gen_getopt_long_spec_from_meta(%args) -> [$status_code, $reason, $payload, \%result_meta]
1165              
1166             Generate Getopt::Long spec from Rinci function metadata.
1167              
1168             This routine will produce a L<Getopt::Long> specification from Rinci function
1169             metadata, as well as some more data structure in the result metadata to help
1170             producing a command-line help/usage message.
1171              
1172             Function arguments will be mapped to command-line options with the same name,
1173             with non-alphanumeric characters changed to C<-> (C<-> is preferred over C<_>
1174             because it lets user avoid pressing Shift on popular keyboards). For example:
1175             C<file_size> becomes C<file-size>, C<file_size.max> becomes C<file-size-max>. If
1176             function argument option name clashes with command-line option or another
1177             existing option, it will be renamed to C<NAME-arg> (or C<NAME-arg2> and so on).
1178             For example: C<help> will become C<help-arg> (if C<common_opts> contains C<help>,
1179             that is).
1180              
1181             Each command-line alias (C<cmdline_aliases> property) in the argument
1182             specification will also be added as command-line option, except if it clashes
1183             with an existing option, in which case this function will warn and skip adding
1184             the alias. For more information about C<cmdline_aliases>, see C<Rinci::function>.
1185              
1186             For arguments with type of C<bool>, Getopt::Long will by default also
1187             automatically recognize C<--noNAME> or C<--no-NAME> in addition to C<--name>. So
1188             this function will also check those names for clashes.
1189              
1190             For arguments with type array of simple scalar, C<--NAME> can be specified more
1191             than once to append to the array.
1192              
1193             If C<per_arg_json> setting is active, and argument's schema is not a "required
1194             simple scalar" (e.g. an array, or a nullable string), then C<--NAME-json> will
1195             also be added to let users input undef (through C<--NAME-json null>) or a
1196             non-scalar value (e.g. C<--NAME-json '[1,2,3]'>). If this name conflicts with
1197             another existing option, a warning will be displayed and the option will not be
1198             added.
1199              
1200             If C<per_arg_yaml> setting is active, and argument's schema is not a "required
1201             simple scalar" (e.g. an array, or a nullable string), then C<--NAME-yaml> will
1202             also be added to let users input undef (through C<--NAME-yaml '~'>) or a
1203             non-scalar value (e.g. C<--NAME-yaml '[foo, bar]'>). If this name conflicts with
1204             another existing option, a warning will be displayed and the option will not be
1205             added. YAML can express a larger set of values, e.g. binary data, circular
1206             references, etc.
1207              
1208             Will produce a hash (Getopt::Long spec), with C<func.specmeta>, C<func.opts>,
1209             C<func.common_opts>, C<func.func_opts> that contain extra information
1210             (C<func.specmeta> is a hash of getopt spec name and a hash of extra information
1211             while C<func.*opts> lists all used option names).
1212              
1213             This function is not exported by default, but exportable.
1214              
1215             Arguments ('*' denotes required arguments):
1216              
1217             =over 4
1218              
1219             =item * B<args> => I<hash>
1220              
1221             Reference to hash which will store the result.
1222              
1223             =item * B<common_opts> => I<hash>
1224              
1225             Common options.
1226              
1227             A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
1228             option specification), C<handler> (Getopt::Long handler). Will be passed to
1229             C<get_args_from_argv()>. Example:
1230              
1231             {
1232             help => {
1233             getopt => 'help|h|?',
1234             handler => sub { ... },
1235             summary => 'Display help and exit',
1236             },
1237             version => {
1238             getopt => 'version|v',
1239             handler => sub { ... },
1240             summary => 'Display version and exit',
1241             },
1242             }
1243              
1244             =item * B<ignore_converted_code> => I<bool> (default: 0)
1245              
1246             Whether to ignore coderefs converted to string.
1247              
1248             Across network through JSON encoding, coderef in metadata (e.g. in
1249             C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
1250             cases, like for tab completion, this is pretty harmless so you can turn this
1251             option on. For example, in the case of C<cmdline_aliases>, the effect is just
1252             that command-line aliases code are not getting executed, but this is usually
1253             okay.
1254              
1255             =item * B<meta>* => I<hash>
1256              
1257             Rinci function metadata.
1258              
1259             =item * B<meta_is_normalized> => I<bool>
1260              
1261             =item * B<per_arg_json> => I<bool> (default: 0)
1262              
1263             Whether to add --NAME-json for non-simple arguments.
1264              
1265             Will also interpret command-line arguments as JSON if assigned to function
1266             arguments, if arguments' schema is not simple scalar.
1267              
1268             =item * B<per_arg_yaml> => I<bool> (default: 0)
1269              
1270             Whether to add --NAME-yaml for non-simple arguments.
1271              
1272             Will also interpret command-line arguments as YAML if assigned to function
1273             arguments, if arguments' schema is not simple scalar.
1274              
1275              
1276             =back
1277              
1278             Returns an enveloped result (an array).
1279              
1280             First element ($status_code) is an integer containing HTTP-like status code
1281             (200 means OK, 4xx caller error, 5xx function error). Second element
1282             ($reason) is a string containing error message, or something like "OK" if status is
1283             200. Third element ($payload) is the actual result, but usually not present when enveloped result is an error response ($status_code is not 2xx). Fourth
1284             element (%result_meta) is called result metadata and is optional, a hash
1285             that contains extra information, much like how HTTP response headers provide additional metadata.
1286              
1287             Return value: (any)
1288              
1289              
1290              
1291             =head2 get_args_from_argv
1292              
1293             Usage:
1294              
1295             get_args_from_argv(%args) -> [$status_code, $reason, $payload, \%result_meta]
1296              
1297             Get subroutine arguments (%args) from command-line arguments (@ARGV).
1298              
1299             Using information in Rinci function metadata's C<args> property, parse command
1300             line arguments C<@argv> into hash C<%args>, suitable for passing into subroutines.
1301              
1302             Currently uses L<Getopt::Long>'s C<GetOptions> to do the parsing.
1303              
1304             As with GetOptions, this function modifies its C<argv> argument, so you might
1305             want to copy the original C<argv> first (or pass a copy instead) if you want to
1306             preserve the original.
1307              
1308             See also: gen_getopt_long_spec_from_meta() which is the routine that generates
1309             the specification.
1310              
1311             This function is not exported by default, but exportable.
1312              
1313             Arguments ('*' denotes required arguments):
1314              
1315             =over 4
1316              
1317             =item * B<allow_extra_elems> => I<bool> (default: 0)
1318              
1319             Allow extraE<sol>unassigned elements in argv.
1320              
1321             If set to 1, then if there are array elements unassigned to one of the
1322             arguments, instead of generating an error, this function will just ignore them.
1323              
1324             This option will be passed to Perinci::Sub::GetArgs::Array's allow_extra_elems.
1325              
1326             =item * B<args> => I<hash>
1327              
1328             Specify input args, with some arguments preset.
1329              
1330             =item * B<argv> => I<array[str]>
1331              
1332             If not specified, defaults to @ARGV
1333              
1334             =item * B<common_opts> => I<hash>
1335              
1336             Common options.
1337              
1338             A hash where the values are hashes containing these keys: C<getopt> (Getopt::Long
1339             option specification), C<handler> (Getopt::Long handler). Will be passed to
1340             C<get_args_from_argv()>. Example:
1341              
1342             {
1343             help => {
1344             getopt => 'help|h|?',
1345             handler => sub { ... },
1346             summary => 'Display help and exit',
1347             },
1348             version => {
1349             getopt => 'version|v',
1350             handler => sub { ... },
1351             summary => 'Display version and exit',
1352             },
1353             }
1354              
1355             =item * B<ggls_res> => I<array>
1356              
1357             Full result from gen_getopt_long_spec_from_meta().
1358              
1359             If you already call C<gen_getopt_long_spec_from_meta()>, you can pass the I<full> enveloped result
1360             here, to avoid calculating twice.
1361              
1362             =item * B<ignore_converted_code> => I<bool> (default: 0)
1363              
1364             Whether to ignore coderefs converted to string.
1365              
1366             Across network through JSON encoding, coderef in metadata (e.g. in
1367             C<cmdline_aliases> property) usually gets converted to string C<CODE>. In some
1368             cases, like for tab completion, this is harmless so you can turn this option on.
1369              
1370             =item * B<meta>* => I<hash>
1371              
1372             =item * B<meta_is_normalized> => I<bool> (default: 0)
1373              
1374             Can be set to 1 if your metadata is normalized, to avoid duplicate effort.
1375              
1376             =item * B<on_missing_required_args> => I<code>
1377              
1378             Execute code when there is missing required args.
1379              
1380             This can be used to give a chance to supply argument value from other sources if
1381             not specified by command-line options. Perinci::CmdLine, for example, uses this
1382             hook to supply value from STDIN or file contents (if argument has C<cmdline_src>
1383             specification key set).
1384              
1385             This hook will be called for each missing argument. It will be supplied hash
1386             arguments: (arg => $the_missing_argument_name, args =>
1387             $the_resulting_args_so_far, spec => $the_arg_spec).
1388              
1389             The hook can return true if it succeeds in making the missing situation
1390             resolved. In this case, this function will not report the argument as missing.
1391              
1392             =item * B<per_arg_json> => I<bool> (default: 0)
1393              
1394             Whether to recognize --ARGNAME-json.
1395              
1396             This is useful for example if you want to specify a value which is not
1397             expressible from the command-line, like 'undef'.
1398              
1399             % script.pl --name-json 'null'
1400              
1401             But every other string will need to be quoted:
1402              
1403             % script.pl --name-json '"foo"'
1404              
1405             See also: per_arg_yaml. You should enable just one instead of turning on both.
1406              
1407             =item * B<per_arg_yaml> => I<bool> (default: 0)
1408              
1409             Whether to recognize --ARGNAME-yaml.
1410              
1411             This is useful for example if you want to specify a value which is not
1412             expressible from the command-line, like 'undef'.
1413              
1414             % script.pl --name-yaml '~'
1415              
1416             See also: per_arg_json. You should enable just one instead of turning on both.
1417              
1418             =item * B<strict> => I<bool> (default: 1)
1419              
1420             Strict mode.
1421              
1422             If set to 0, will still return parsed argv even if there are parsing errors
1423             (reported by Getopt::Long). If set to 1 (the default), will die upon error.
1424              
1425             Normally you would want to use strict mode, for more error checking. Setting off
1426             strict is used by, for example, Perinci::Sub::Complete during completion where
1427             the command-line might still be incomplete.
1428              
1429             Should probably be named C<ignore_errors> or C<allow_unknown_options>. :-)
1430              
1431              
1432             =back
1433              
1434             Returns an enveloped result (an array).
1435              
1436             First element ($status_code) is an integer containing HTTP-like status code
1437             (200 means OK, 4xx caller error, 5xx function error). Second element
1438             ($reason) is a string containing error message, or something like "OK" if status is
1439             200. Third element ($payload) is the actual result, but usually not present when enveloped result is an error response ($status_code is not 2xx). Fourth
1440             element (%result_meta) is called result metadata and is optional, a hash
1441             that contains extra information, much like how HTTP response headers provide additional metadata.
1442              
1443             Return value: (any)
1444              
1445              
1446             Error codes:
1447              
1448             =over
1449              
1450             =item * 400 - Error in Getopt::Long option specification, e.g. in common_opts.
1451              
1452             =item * 500 - failure in GetOptions, meaning argv is not valid according to metadata
1453             specification (only if 'strict' mode is enabled).
1454              
1455             =item * 501 - coderef in cmdline_aliases got converted into a string, probably because
1456             the metadata was transported (e.g. through Riap::HTTP/Riap::Simple).
1457              
1458             =back
1459              
1460             =head1 FAQ
1461              
1462             =head1 HOMEPAGE
1463              
1464             Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-GetArgs-Argv>.
1465              
1466             =head1 SOURCE
1467              
1468             Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-GetArgs-Argv>.
1469              
1470             =head1 SEE ALSO
1471              
1472             L<Perinci>
1473              
1474             =head1 AUTHOR
1475              
1476             perlancar <perlancar@cpan.org>
1477              
1478             =head1 CONTRIBUTORS
1479              
1480             =for stopwords Olivier Mengué Steven Haryanto
1481              
1482             =over 4
1483              
1484             =item *
1485              
1486             Olivier Mengué <dolmen@cpan.org>
1487              
1488             =item *
1489              
1490             Steven Haryanto <stevenharyanto@gmail.com>
1491              
1492             =back
1493              
1494             =head1 CONTRIBUTING
1495              
1496              
1497             To contribute, you can send patches by email/via RT, or send pull requests on
1498             GitHub.
1499              
1500             Most of the time, you don't need to build the distribution yourself. You can
1501             simply modify the code, then test via:
1502              
1503             % prove -l
1504              
1505             If you want to build the distribution (e.g. to try to install it locally on your
1506             system), you can install L<Dist::Zilla>,
1507             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
1508             Dist::Zilla plugin and/or Pod::Weaver::Plugin. Any additional steps required
1509             beyond that are considered a bug and can be reported to me.
1510              
1511             =head1 COPYRIGHT AND LICENSE
1512              
1513             This software is copyright (c) 2022, 2021, 2020, 2019, 2017, 2016, 2015, 2014, 2013, 2012, 2011 by perlancar <perlancar@cpan.org>.
1514              
1515             This is free software; you can redistribute it and/or modify it under
1516             the same terms as the Perl 5 programming language system itself.
1517              
1518             =head1 BUGS
1519              
1520             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-GetArgs-Argv>
1521              
1522             When submitting a bug or request, please include a test-file or a
1523             patch to an existing test-file that illustrates the bug or desired
1524             feature.
1525              
1526             =cut