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