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; |