File Coverage

blib/lib/Net/FreeIPA/API/Convert.pm
Criterion Covered Total %
statement 81 81 100.0
branch 34 36 94.4
condition 11 12 91.6
subroutine 10 10 100.0
pod 3 3 100.0
total 139 142 97.8


line stmt bran cond sub pod time code
1             package Net::FreeIPA::API::Convert;
2             $Net::FreeIPA::API::Convert::VERSION = '3.0.1';
3 1     1   22431 use strict;
  1         1  
  1         25  
4 1     1   3 use warnings qw(FATAL numeric);
  1         1  
  1         31  
5              
6 1     1   317 use Net::FreeIPA::Request;
  1         1  
  1         37  
7              
8 1     1   4 use Types::Serialiser; # is used by JSON::XS
  1         1  
  1         20  
9 1     1   421 use Readonly;
  1         3517  
  1         42  
10              
11 1     1   4 use base qw(Exporter);
  1         1  
  1         666  
12              
13             our @EXPORT_OK = qw(process_args);
14              
15             # Convert dispatch table
16             Readonly::Hash my %CONVERT_DISPATCH => {
17             str => sub {my $val = shift; return "$val";}, # stringify
18             int => sub {my $val = shift; return 0 + $val;}, # Force internal conversion to int
19             float => sub {my $val = shift; return 1.0 * $val;}, # Force internal conversion to float
20             bool => sub {my $val = shift; return $val ? Types::Serialiser::true : Types::Serialiser::false;},
21             };
22              
23             # Aliases for each dispatch
24             Readonly::Hash my %CONVERT_ALIAS => {
25             str => [qw(unicode DNSName)],
26             };
27              
28             Readonly my $API_RPC_OPTION_PATTERN => '^__';
29              
30              
31             =head1 NAME
32              
33             Net::FreeIPA::Convert provides type conversion for Net::FreeIPA
34              
35             =head2 Public functions
36              
37             =over
38              
39             =item convert
40              
41             Convert/cast value to type.
42              
43             If a type is not found in the dispatch tabel, log a warning and return the value as-is.
44              
45             Always returns value, dies when dealing with non-convertable type (using 'FATAL numeric').
46              
47             =cut
48              
49             # Do not use intermediate variables for the result
50              
51             sub convert
52             {
53 21     21 1 1044 my ($value, $type) = @_;
54              
55 21         60 my $funcref = $CONVERT_DISPATCH{$type};
56              
57 21 100       97 if(!defined($funcref)) {
58             # is it an alias?
59 3         9 foreach my $tmpref (sort keys %CONVERT_ALIAS) {
60 3 100       22 $funcref = $CONVERT_DISPATCH{$tmpref} if (grep {$_ eq $type} @{$CONVERT_ALIAS{$tmpref}});
  6         52  
  3         22  
61             }
62             };
63              
64 21 100       34 if (defined($funcref)) {
65 20         13 my $vref = ref($value);
66 20 100       34 if ($vref eq 'ARRAY') {
    100          
67 3         4 return [map {$funcref->($_)} @$value];
  7         14  
68             } elsif ($vref eq 'HASH') {
69 1         7 return {map {$_ => $funcref->($value->{$_})} sort keys %$value};
  3         7  
70             } else {
71 16         22 return $funcref->($value);
72             };
73             } else {
74 1         2 return $value;
75             }
76             }
77              
78             =item check_command
79              
80             Given the (single) command hashref C and C,
81             verify the value, convert it and add it to C.
82              
83             (Adding to where is required to avoid using intermdiadate varaibles
84             which can cause problems for the internal types).
85              
86             Returns errormessage (which is undef on success).
87              
88             =cut
89              
90             sub check_command
91             {
92 23     23 1 5698 my ($cmd, $value, $where) = @_;
93              
94 23         14 my $errmsg;
95              
96 23         22 my $ref = ref($value);
97 23         22 my $name = $cmd->{name};
98              
99             # Check mandatory / undef
100             # only mandatory if required and no autofill/default
101 23 100 100     104 my $mandatory = ($cmd->{required} && (! $cmd->{autofill})) ? 1 : 0;
102              
103             # Check multivalue
104 23 100       75 my $multi = $cmd->{multivalue} ? 1 : 0;
105              
106 23 100 100     113 if (! defined($value)) {
    100 100        
      66        
107 6 100       8 if ($mandatory) {
108 3         5 $errmsg = "name $name mandatory with undefined value";
109             };
110             } elsif((! $ref && ! $multi) ||
111             (($ref eq 'ARRAY') && $multi) ) {
112             # Convert and add to where
113 11         10 my $wref = ref($where);
114 11         10 local $@;
115 11         11 eval {
116 11 100       17 if ($wref eq 'ARRAY') {
    100          
117 7         10 push(@$where, convert($value, $cmd->{type}));
118             } elsif ($wref eq 'HASH') {
119 3         8 $where->{$name} = convert($value, $cmd->{type});
120             } else {
121 1         3 $errmsg = "name $name unknown where ref $wref";
122             };
123             };
124 11 100       31 $errmsg = "name $name where ref $wref died $@" if ($@);
125             } else {
126 6         11 $errmsg = "name $name wrong multivalue (multi $multi, ref $ref)";
127             };
128              
129 23         35 return $errmsg;
130             }
131              
132             =item process_args
133              
134             Given the command hasref C and the arguments passed, return
135              
136             =over
137              
138             =item errmsg: an error message in case of failure
139              
140             =item posarg: arrayref with positional arguments
141              
142             =item opts: hasref with options
143              
144             =item rpc: hashref with options for the RPC call
145              
146             (All options starting with C<__> are passed as options to
147             C, with C<__> prefix removed).
148              
149             =back
150              
151             Positional argument and option values are converted
152             using C function.
153              
154             =cut
155              
156             sub process_args
157             {
158 6     6 1 441 my ($cmds, @args) = @_;
159              
160 6         7 my $cmdname = $cmds->{name};
161              
162 6         6 my $posargs = [];
163 6         7 my $opts = {};
164 6         6 my $rpc = {};
165 6         4 my $errmsg;
166              
167             my $err_req = sub {
168 5     5   13 $errmsg = join(" ", "$cmdname:", shift, $errmsg);
169 5         12 return mkrequest($cmdname, error => $errmsg);
170 6         16 };
171              
172             # Check posargs
173 6         6 my $aidx = 0;
174 6 50       5 foreach my $cmd (@{$cmds->{takes_args} || []}) {
  6         17  
175 6         5 $aidx += 1;
176 6         8 $errmsg = check_command($cmd, shift(@args), $posargs);
177 6 100       15 return &$err_req("$aidx-th argument") if $errmsg;
178             }
179              
180             # Check options
181 4         6 my %origopts = @args;
182              
183             # Process all options
184             # The processed options are removed from %origopts
185 4 50       22 foreach my $cmd (@{$cmds->{takes_options} || []}) {
  4         11  
186 4         3 my $name = $cmd->{name};
187 4         8 $errmsg = check_command($cmd, delete $origopts{$name}, $opts);
188 4 100       9 return &$err_req("option") if $errmsg;
189             }
190              
191             # Filter out any RPC options
192             # Any remaing key is invalid
193 2         5 foreach my $name (sort keys %origopts) {
194 2 100       5 if ($name =~ m/$API_RPC_OPTION_PATTERN/) {
195 1         6 my $val = $origopts{$name};
196 1         3 $name =~ s/$API_RPC_OPTION_PATTERN//;
197 1         12 $rpc->{$name} = $val;
198             } else {
199 1         13 return &$err_req("option invalid name $name");
200             };
201             }
202              
203             # No error
204 1         4 return mkrequest($cmdname, args => $posargs, opts => $opts, rpc => $rpc);
205             }
206              
207             =pod
208              
209             =back
210              
211             =cut
212              
213             1;