File Coverage

blib/lib/Getopt/Long/Util.pm
Criterion Covered Total %
statement 90 142 63.3
branch 64 102 62.7
condition 27 46 58.7
subroutine 7 10 70.0
pod 5 5 100.0
total 193 305 63.2


line stmt bran cond sub pod time code
1             package Getopt::Long::Util;
2              
3 1     1   54878 use 5.010001;
  1         11  
4 1     1   4 use strict;
  1         1  
  1         15  
5 1     1   3 use warnings;
  1         2  
  1         316  
6              
7             require Exporter;
8             our @ISA = qw(Exporter);
9             our @EXPORT_OK = qw(
10             parse_getopt_long_opt_spec
11             humanize_getopt_long_opt_spec
12             detect_getopt_long_script
13             gen_getopt_long_spec_from_getopt_std_spec
14             array_getopt_long_spec_to_hash
15             );
16              
17             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
18             our $DATE = '2022-10-12'; # DATE
19             our $DIST = 'Getopt-Long-Util'; # DIST
20             our $VERSION = '0.898'; # VERSION
21              
22             our %SPEC;
23              
24             $SPEC{parse_getopt_long_opt_spec} = {
25             v => 1.1,
26             summary => 'Parse a single Getopt::Long option specification',
27             description => <<'_',
28              
29             Will produce a hash with some keys:
30              
31             * `is_arg` (if true, then option specification is the special `<>` for argument
32             callback)
33             * `opts` (array of option names, in the order specified in the opt spec)
34             * `type` (string, type name)
35             * `desttype` (either '', or '@' or '%'),
36             * `is_neg` (true for `--opt!`)
37             * `is_inc` (true for `--opt+`)
38             * `min_vals` (int, usually 0 or 1)
39             * `max_vals` (int, usually 0 or 1 except for option that requires multiple
40             values)
41              
42             Will return undef if it can't parse the string.
43              
44             _
45             args => {
46             optspec => {
47             schema => 'str*',
48             req => 1,
49             pos => 0,
50             },
51             },
52             args_as => 'array',
53             result_naked => 1,
54             result => {
55             schema => 'hash*',
56             },
57             examples => [
58             {
59             args => {optspec => 'help|h|?'},
60             result => {dash_prefix=>'', opts=>['help', 'h', '?']},
61             },
62             {
63             args => {optspec=>'--foo=s'},
64             result => {dash_prefix=>'--', opts=>['foo'], type=>'s', desttype=>''},
65             },
66             ],
67             };
68             # BEGIN_BLOCK: parse_getopt_long_opt_spec
69             sub parse_getopt_long_opt_spec {
70 25     25 1 888 my $optspec = shift;
71 25 100       46 return {is_arg=>1, dash_prefix=>'', opts=>[]}
72             if $optspec eq '<>';
73 23 100       218 $optspec =~ qr/\A
74             (?P-{0,2})
75             (?P[A-Za-z0-9_][A-Za-z0-9_-]*)
76             (?P (?: \| (?:[^:|!+=:-][^:|!+=:]*) )*)?
77             (?:
78             (?P!) |
79             (?P\+) |
80             (?:
81             =
82             (?P[siof])
83             (?P|[%@])?
84             (?:
85             \{
86             (?: (?P\d+), )?
87             (?P\d+)
88             \}
89             )?
90             ) |
91             (?:
92             :
93             (?P[siof])
94             (?P|[%@])?
95             ) |
96             (?:
97             :
98             (?P-?\d+)
99             (?P|[%@])?
100             ) |
101             (?:
102             :
103             (?P\+)
104             (?P|[%@])?
105             )
106             )?
107             \z/x
108             or return;
109 1     1   351 my %res = %+;
  1         336  
  1         1358  
  21         265  
110              
111 21 100       69 if (defined $res{optnum}) {
112 1         2 $res{type} = 'i';
113             }
114              
115 21 100       36 if ($res{aliases}) {
116 7         8 my @als;
117 7         16 for my $al (split /\|/, $res{aliases}) {
118 18 100       31 next unless length $al;
119 11 50       13 next if $al eq $res{name};
120 11 50       19 next if grep {$_ eq $al} @als;
  4         9  
121 11         15 push @als, $al;
122             }
123 7         18 $res{opts} = [$res{name}, @als];
124             } else {
125 14         25 $res{opts} = [$res{name}];
126             }
127 21         27 delete $res{name};
128 21         24 delete $res{aliases};
129              
130 21 100       33 $res{is_neg} = 1 if $res{is_neg};
131 21 100       35 $res{is_inc} = 1 if $res{is_inc};
132              
133 21         64 \%res;
134             }
135             # END_BLOCK: parse_getopt_long_opt_spec
136              
137             $SPEC{humanize_getopt_long_opt_spec} = {
138             v => 1.1,
139             description => <<'_',
140              
141             Convert option specification into a more human-friendly
142             notation that is suitable for including in help/usage text, for example:
143              
144             help|h|? -> "--help, -h, -?"
145             help|h|? -> "--help | -h | -?" # if you provide 'separator'
146             --foo=s -> "--foo=s"
147             --foo=s -> "--foo=somelabel" # if you provide 'value_label'
148             --foo:s -> "--foo[=s]"
149             --foo=s@ -> "(--foo=s)+"
150             --foo=s% -> "(--foo key=value)+"
151             --foo=s% -> "(--foo somelabel1=somelabel2)+" # if you provide 'key_label' and 'value_label'
152             --debug! -> "--(no)debug"
153              
154             It also produces POD-formatted string for use in POD documentation:
155              
156             --foo=s -> {plaintext=>"--foo=s", pod=>"B<--foo>=I"}
157             # if you set 'extended' to true
158              
159             Will die if can't parse the optspec string.
160              
161             _
162             args => {
163             optspec => {
164             schema => 'str*',
165             req => 1,
166             pos => 0,
167             },
168             separator => {
169             schema => 'str*',
170             default => ', ',
171             },
172             key_label => {
173             schema => 'str*',
174             default => 'key',
175             },
176             opt_link => {
177             schema => 'str*', # XXX url? podlink?
178             },
179             value_label => {
180             schema => 'str*',
181             },
182             value_label_link => {
183             schema => 'str*', # XXX url? podlink?
184             },
185             extended => {
186             summary => 'If set to true, will return a hash of multiple formats instead of a single plaintext format',
187             schema => 'bool*',
188             },
189             },
190             args_as => 'array',
191             result_naked => 1,
192             result => {
193             schema => ['any*', {of=>[['str*'], ['hash*', {of=>'str*'}]]}],
194             },
195             };
196             sub humanize_getopt_long_opt_spec {
197 13 100   13 1 1998 my $opts = {}; $opts = shift if ref $_[0] eq 'HASH';
  13         28  
198 13         18 my $optspec = shift;
199              
200 13 50       21 my $parse = parse_getopt_long_opt_spec($optspec)
201             or die "Can't parse opt spec $optspec";
202              
203 13 100       23 return "argument" if $parse->{is_arg};
204              
205 12         12 my $plain_res = '';
206 12         13 my $pod_res = '';
207 12         13 my $i = 0;
208 12         12 for (@{ $parse->{opts} }) {
  12         20  
209 18         17 $i++;
210 18         16 my $opt_plain_res = '';
211 18         15 my $opt_pod_res = '';
212 18 100 100     37 if ($parse->{is_neg} && length($_) > 1) {
213 2         4 $opt_plain_res .= "--(no)$_";
214 2 50       5 $opt_pod_res .= defined($opts->{opt_link}) ? "L<--(no)$_|$opts->{opt_link}>" : "B<--(no)$_>";
215             } else {
216 16 100       28 if (length($_) > 1) {
217 11         13 $opt_plain_res .= "--$_";
218 11 50       21 $opt_pod_res .= defined($opts->{opt_link}) ? "L<--$_|$opts->{opt_link}>" : "B<--$_>";
219             } else {
220 5         6 $opt_plain_res .= "-$_";
221 5 50       7 $opt_pod_res .= defined($opts->{opt_link}) ? "L<-$_|$opts->{opt_link}>" : "B<-$_>";
222             }
223 16 100 66     35 if ($i==1 && ($parse->{type} || $parse->{opttype})) {
      66        
224             # show value label
225 8   100     21 my $key_label = $opts->{key_label} // 'key';
226             my $value_label = $opts->{value_label} //
227 8   66     21 $parse->{type} // $parse->{opttype};
      33        
228              
229 8 50       11 $opt_plain_res .= "[" if $parse->{opttype};
230 8 100 66     19 $opt_plain_res .= ($parse->{type} && $parse->{desttype} eq '%' ? " " : "=");
231 8 100       16 $opt_plain_res .= "$key_label=" if $parse->{desttype} eq '%';
232 8         8 $opt_plain_res .= $value_label;
233 8 50       11 $opt_plain_res .= "]" if $parse->{opttype};
234              
235 8 50       10 $opt_pod_res .= "[" if $parse->{opttype};
236 8 100 66     19 $opt_pod_res .= ($parse->{type} && $parse->{desttype} eq '%' ? " " : "=");
237 8 100       13 $opt_pod_res .= "I<$key_label>=" if $parse->{desttype} eq '%';
238 8 50       15 $opt_pod_res .= defined $opts->{value_label_link} ? "L<$value_label|$opts->{value_label_link}>" : "I<$value_label>";
239 8 50       10 $opt_pod_res .= "]" if $parse->{opttype};
240             }
241 16 100 100     46 $opt_plain_res = "($opt_plain_res)+" if ($parse->{desttype} // '') =~ /@|%/;
242 16 100 100     36 $opt_pod_res = "($opt_pod_res)+" if ($parse->{desttype} // '') =~ /@|%/;
243             }
244              
245 18 100 50     29 $plain_res .= ($opts->{separator} // ", ") if length($plain_res);
246 18 100 50     32 $pod_res .= ($opts->{separator} // ", ") if length($pod_res);
247              
248 18         18 $plain_res .= $opt_plain_res;
249 18         22 $pod_res .= $opt_pod_res;
250             }
251              
252 12 100       21 if ($opts->{extended}) {
253             return {
254 1         7 plaintext => $plain_res,
255             pod => $pod_res,
256             };
257             } else {
258 11         45 $plain_res;
259             }
260             }
261              
262             $SPEC{detect_getopt_long_script} = {
263             v => 1.1,
264             summary => 'Detect whether a file is a Getopt::Long-based CLI script',
265             description => <<'_',
266              
267             The criteria are:
268              
269             * the file must exist and readable;
270              
271             * (optional, if `include_noexec` is false) file must have its executable mode
272             bit set;
273              
274             * content must start with a shebang C<#!>;
275              
276             * either: must be perl script (shebang line contains 'perl') and must contain
277             something like `use Getopt::Long`;
278              
279             _
280             args => {
281             filename => {
282             summary => 'Path to file to be checked',
283             schema => 'str*',
284             pos => 0,
285             cmdline_aliases => {f=>{}},
286             },
287             string => {
288             summary => 'String to be checked',
289             schema => 'buf*',
290             },
291             include_noexec => {
292             summary => 'Include scripts that do not have +x mode bit set',
293             schema => 'bool*',
294             default => 1,
295             },
296             },
297             args_rels => {
298             'req_one' => ['filename', 'string'],
299             },
300             };
301             sub detect_getopt_long_script {
302 0     0 1 0 my %args = @_;
303              
304 0 0 0     0 (defined($args{filename}) xor defined($args{string}))
305             or return [400, "Please specify either filename or string"];
306 0   0     0 my $include_noexec = $args{include_noexec} // 1;
307              
308 0         0 my $yesno = 0;
309 0         0 my $reason = "";
310 0         0 my %extrameta;
311              
312 0         0 my $str = $args{string};
313             DETECT:
314             {
315 0 0       0 if (defined $args{filename}) {
  0         0  
316 0         0 my $fn = $args{filename};
317 0 0       0 unless (-f $fn) {
318 0         0 $reason = "'$fn' is not a file";
319 0         0 last;
320             };
321 0 0 0     0 if (!$include_noexec && !(-x _)) {
322 0         0 $reason = "'$fn' is not an executable";
323 0         0 last;
324             }
325 0         0 my $fh;
326 0 0       0 unless (open $fh, "<", $fn) {
327 0         0 $reason = "Can't be read";
328 0         0 last;
329             }
330             # for efficiency, we read a bit only here
331 0         0 read $fh, $str, 2;
332 0 0       0 unless ($str eq '#!') {
333 0         0 $reason = "Does not start with a shebang (#!) sequence";
334 0         0 last;
335             }
336 0         0 my $shebang = <$fh>;
337 0 0       0 unless ($shebang =~ /perl/) {
338 0         0 $reason = "Does not have 'perl' in the shebang line";
339 0         0 last;
340             }
341 0         0 seek $fh, 0, 0;
342             {
343 0         0 local $/;
  0         0  
344 0         0 $str = <$fh>;
345             }
346 0         0 close $fh;
347             }
348 0 0       0 unless ($str =~ /\A#!/) {
349 0         0 $reason = "Does not start with a shebang (#!) sequence";
350 0         0 last;
351             }
352 0 0       0 unless ($str =~ /\A#!.*perl/) {
353 0         0 $reason = "Does not have 'perl' in the shebang line";
354 0         0 last;
355             }
356              
357             # NOTE: the presence of \s* pattern after ^ causes massive slowdown of
358             # the regex when we reach many thousands of lines, so we use split()
359              
360             #if ($str =~ /^\s*(use|require)\s+(Getopt::Long(?:::Complete)?)(\s|;)/m) {
361             # $yesno = 1;
362             # $extrameta{'func.module'} = $2;
363             # last DETECT;
364             #}
365              
366 0         0 for (split /^/, $str) {
367 0 0       0 if (/^\s*(use|require)\s+(Getopt::Long(?:::Complete|::Less|::EvenLess)?)(\s|;|$)/) {
368 0         0 $yesno = 1;
369 0         0 $extrameta{'func.module'} = $2;
370 0         0 last DETECT;
371             }
372             }
373              
374 0         0 $reason = "Can't find any statement requiring Getopt::Long(?::Complete|::Less|::EvenLess)? module";
375             } # DETECT
376              
377 0         0 [200, "OK", $yesno, {"func.reason"=>$reason, %extrameta}];
378             }
379              
380             $SPEC{gen_getopt_long_spec_from_getopt_std_spec} = {
381             v => 1.1,
382             summary => 'Generate Getopt::Long spec from Getopt::Std spec',
383             args => {
384             spec => {
385             summary => 'Getopt::Std spec string',
386             schema => 'str*',
387             req => 1,
388             pos => 0,
389             },
390             is_getopt => {
391             summary => 'Whether to assume spec is for getopt() or getopts()',
392             description => <<'_',
393              
394             By default spec is assumed to be for getopts() instead of getopt(). This means
395             that for a spec like `abc:`, `a` and `b` don't take argument while `c` does. But
396             if `is_getopt` is true, the meaning of `:` is reversed: `a` and `b` take
397             arguments while `c` doesn't.
398              
399             _
400             schema => 'bool',
401             },
402             },
403             result_naked => 1,
404             result => {
405             schema => 'hash*',
406             },
407             };
408             sub gen_getopt_long_spec_from_getopt_std_spec {
409 0     0 1 0 my %args = @_;
410              
411 0         0 my $is_getopt = $args{is_getopt};
412 0         0 my $spec = {};
413              
414 0         0 while ($args{spec} =~ /(.)(:?)/g) {
415             $spec->{$1 . ($is_getopt ? ($2 ? "" : "=s") : ($2 ? "=s" : ""))} =
416 0 0   0   0 sub {};
    0          
    0          
417             }
418              
419 0         0 $spec;
420             }
421              
422             $SPEC{array_getopt_long_spec_to_hash} = {
423             v => 1.1,
424             summary => 'Convert array form of Getopt::Long spec to hash',
425             description => <<'_',
426              
427             's `GetOptions` function accepts a list of arguments. The first
428             optional argument is a hash for option storage. After that, a list of option
429             specs (e.g. `foo=s`), each optionally followed by a reference to specify
430             destination (e.g. a reference to scalar, or array, or code).
431              
432             Die on failure (e.g. invalid option spec).
433              
434             This routine converts that array into a hash of option specs as keys and
435             destinations as values. If an option spec does not have a destination, its
436             destination is set to `undef`. If hash storage is specified then the destination
437             will fall back to the hash storage's appropriate key when a specific destination
438             is not specified.
439              
440             Note that by converting to hash, 1) duplicate option specs are merged; and 2)
441             order of option specs is not preserved.
442              
443             _
444             args => {
445             spec => {
446             summary => 'Getopt::Long spec',
447             schema => 'array*',
448             req => 1,
449             pos => 0,
450             },
451             },
452             args_as => 'array',
453             result_naked => 1,
454             result => {
455             schema => 'hash*',
456             },
457             };
458             sub array_getopt_long_spec_to_hash {
459 4     4 1 8527 my $go_spec = [ @_ ];
460 4         5 my $hash_spec = {};
461              
462 4         5 my $hash_storage;
463 4 100 100     17 $hash_storage = shift @$go_spec
464             if @$go_spec && ref $go_spec->[0] eq 'HASH';
465              
466 4         10 while (@$go_spec) {
467 9         11 my $opt_spec = shift @$go_spec;
468 9         10 my $dest;
469 9 100 66     24 if (@$go_spec && ref $go_spec->[0]) {
    100          
470 5         7 $dest = shift @$go_spec;
471             } elsif ($hash_storage) {
472 2 50       4 my $res = parse_getopt_long_opt_spec($opt_spec)
473             or die "Invalid option spec '$opt_spec'";
474 2         4 my $name = $res->{opts}[0];
475 2 100       5 $hash_storage->{$name} = undef unless exists $hash_storage->{$name};
476             $dest = ref $hash_storage->{$name} ?
477             $hash_storage->{$name} :
478 2 100       7 \($hash_storage->{$name});
479             }
480 9         16 $hash_spec->{$opt_spec} = $dest;
481             }
482              
483 4         16 $hash_spec;
484             }
485              
486             1;
487             # ABSTRACT: Utilities for Getopt::Long
488              
489             __END__