File Coverage

blib/lib/Perinci/Sub/ConvertArgs/Argv.pm
Criterion Covered Total %
statement 61 61 100.0
branch 21 24 87.5
condition 12 18 66.6
subroutine 8 8 100.0
pod 1 1 100.0
total 103 112 91.9


line stmt bran cond sub pod time code
1             package Perinci::Sub::ConvertArgs::Argv;
2              
3             our $DATE = '2016-03-16'; # DATE
4             our $VERSION = '0.08'; # VERSION
5              
6 1     1   16324 use 5.010001;
  1         3  
7 1     1   3 use strict;
  1         1  
  1         16  
8 1     1   7 use warnings;
  1         1  
  1         26  
9              
10 1     1   412 use Data::Sah::Util::Type qw(is_simple);
  1         642  
  1         48  
11              
12 1     1   5 use Exporter;
  1         1  
  1         623  
13             our @ISA = qw(Exporter);
14             our @EXPORT_OK = qw(convert_args_to_argv);
15              
16             our %SPEC;
17              
18             sub _json {
19 2     2   475 require JSON::MaybeXS;
20 2         4233 state $json = JSON::MaybeXS->new->allow_nonref;
21 2         28 $json->encode($_[0]);
22             }
23              
24             sub _encode {
25 3 100   3   9 ref($_[0]) ? _json($_[0]) : $_[0];
26             }
27              
28             $SPEC{convert_args_to_argv} = {
29             v => 1.1,
30             summary => 'Convert hash arguments to command-line options (and arguments)',
31             description => <<'_',
32              
33             Convert hash arguments to command-line arguments. This is the reverse of
34             `Perinci::Sub::GetArgs::Argv::get_args_from_argv`.
35              
36             Note: currently the function expects schemas in metadata to be normalized
37             already.
38              
39             _
40             args => {
41             args => {req=>1, schema=>'hash*', pos=>0},
42             meta => {req=>0, schema=>'hash*', pos=>1},
43             use_pos => {
44             summary => 'Whether to use positional arguments',
45             schema => 'bool',
46             description => <<'_',
47              
48             For example, given this metadata:
49              
50             {
51             v => 1.1,
52             args => {
53             arg1 => {pos=>0, req=>1},
54             arg2 => {pos=>1},
55             arg3 => {},
56             },
57             }
58              
59             then under `use_pos=0` the hash `{arg1=>1, arg2=>2, arg3=>'a b'}` will be
60             converted to `['--arg1', 1, '--arg2', 2, '--arg3', 'a b']`. Meanwhile if
61             `use_pos=1` the same hash will be converted to `[1, 2, '--arg3', 'a b']`.
62              
63             _
64             },
65             },
66             };
67             sub convert_args_to_argv {
68 6     6 1 10007 my %fargs = @_;
69              
70 6 50       19 my $iargs = $fargs{args} or return [400, "Please specify args"];
71 6   100     15 my $meta = $fargs{meta} // {v=>1.1};
72 6   100     16 my $args_prop = $meta->{args} // {};
73              
74 6   50     13 my $v = $meta->{v} // 1.0;
75 6 50       13 return [412, "Sorry, only metadata version 1.1 is supported (yours: $v)"]
76             unless $v == 1.1;
77              
78 6         2 my @argv;
79 6         16 my %iargs = %$iargs; # copy 'coz we will delete them one by one as we fill
80              
81 6 100       12 if ($fargs{use_pos}) {
82 2         5 for my $arg (sort {$args_prop->{$a}{pos} <=> $args_prop->{$b}{pos}}
  1         3  
83 5         10 grep {defined $args_prop->{$_}{pos}} keys %iargs) {
84 3         5 my $pos = $args_prop->{$arg}{pos};
85 3 100       4 if ($args_prop->{$arg}{greedy}) {
86 1         14 my $sch = $args_prop->{$arg}{schema};
87             my $is_array_of_simple = $sch && $sch->[0] eq 'array' &&
88 1   33     14 $sch->[1]{of} && is_simple($sch->[1]{of});
89 1         21 for my $el (@{ $iargs{$arg} }) {
  1         3  
90 2 50       4 $argv[$pos] = $is_array_of_simple ? $el : _encode($el);
91 2         3 $pos++;
92             }
93             } else {
94 2         4 $argv[$pos] = _encode($iargs{$arg});
95             }
96 3         6 delete $iargs{$arg};
97             }
98             }
99              
100 6         14 for (sort keys %iargs) {
101 8         9 my $sch = $args_prop->{$_}{schema};
102 8   66     27 my $is_bool = $sch && $sch->[0] eq 'bool';
103             my $is_array_of_simple = $sch && $sch->[0] eq 'array' &&
104 8   33     34 $sch->[1]{of} && is_simple($sch->[1]{of});
105             my $can_be_comma_separated = $is_array_of_simple &&
106 8   100     52 $sch->[1]{of}[0] =~ /\A(int|float)\z/; # XXX as well as other simple types that cannot contain commas
107 8         7 my $opt = $_; $opt =~ s/_/-/g;
  8         9  
108 8 100       13 my $dashopt = length($opt) > 1 ? "--$opt" : "-$opt";
109 8 100       15 if ($is_bool) {
    100          
    100          
110 2 100       5 if ($iargs{$_}) {
111 1         3 push @argv, $dashopt;
112             } else {
113 1         3 push @argv, "--no$opt";
114             }
115             } elsif ($can_be_comma_separated) {
116 1         3 push @argv, "$dashopt", join(",", @{ $iargs{$_} });
  1         4  
117             } elsif ($is_array_of_simple) {
118 1         1 for (@{ $iargs{$_} }) {
  1         3  
119 2         4 push @argv, "$dashopt", $_;
120             }
121             } else {
122 4 100       6 if (ref $iargs{$_}) {
123 1         4 push @argv, "$dashopt-json", _encode($iargs{$_});
124             } else {
125 3         7 push @argv, $dashopt, "$iargs{$_}";
126             }
127             }
128             }
129 6         26 [200, "OK", \@argv];
130             }
131              
132             1;
133             # ABSTRACT: Convert hash arguments to command-line options (and arguments)
134              
135             __END__