line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Params::Profile; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
2161
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
122
|
|
4
|
3
|
|
|
3
|
|
16
|
use warnings; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
114
|
|
5
|
3
|
|
|
3
|
|
1068
|
use Params::Profile::Data_FormValidator; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
94
|
|
6
|
3
|
|
|
3
|
|
1539
|
use Params::Profile::Params_Check; |
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
92
|
|
7
|
|
|
|
|
|
|
|
8
|
3
|
|
|
3
|
|
24
|
use base qw/Class::Data::Inheritable/; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
2683
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our $VERSION = '0.11'; |
11
|
|
|
|
|
|
|
|
12
|
3
|
|
|
3
|
|
1265
|
use constant NO_ARGS => {}; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
183
|
|
13
|
3
|
|
|
3
|
|
18
|
use constant NO_PROFILE => undef; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
17286
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my %Cache; |
16
|
|
|
|
|
|
|
my $Mod_DV = __PACKAGE__ . '::Data_FormValidator'; |
17
|
|
|
|
|
|
|
my $Mod_PC = __PACKAGE__ . '::Params_Check'; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata(qw/Profiles/); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
__PACKAGE__->Profiles({}); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=head1 NAME |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
Params::Profile - module for registering Parameter profiles |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head1 SYNOPSIS |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
package Foo::Bar; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
use Params::Profile; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
### Single profile |
34
|
|
|
|
|
|
|
Params::Profile->register_profile( |
35
|
|
|
|
|
|
|
'method' => 'subroto', |
36
|
|
|
|
|
|
|
'profile' => { |
37
|
|
|
|
|
|
|
testkey1 => { required => 1 }, |
38
|
|
|
|
|
|
|
testkey2 => { |
39
|
|
|
|
|
|
|
required => 1, |
40
|
|
|
|
|
|
|
allow => qr/^\d+$/, |
41
|
|
|
|
|
|
|
}, |
42
|
|
|
|
|
|
|
testkey3 => { |
43
|
|
|
|
|
|
|
allow => qr/^\w+$/, |
44
|
|
|
|
|
|
|
}, |
45
|
|
|
|
|
|
|
}, |
46
|
|
|
|
|
|
|
); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub subroto { |
49
|
|
|
|
|
|
|
my (%params) = @_; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
return unlesss Params::Profile->validate('params' => \%params); |
52
|
|
|
|
|
|
|
### DO SOME STUFF HERE ... |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
my $profile = Params::Profile->get_profile('method' => 'subroto'); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
### Multiple Profile |
58
|
|
|
|
|
|
|
Params::Profile->register_profile( |
59
|
|
|
|
|
|
|
'method' => 'subalso', |
60
|
|
|
|
|
|
|
'profile' => [ |
61
|
|
|
|
|
|
|
'subroto', |
62
|
|
|
|
|
|
|
{ |
63
|
|
|
|
|
|
|
testkey4 => { required => 1 }, |
64
|
|
|
|
|
|
|
testkey5 => { |
65
|
|
|
|
|
|
|
required => 1, |
66
|
|
|
|
|
|
|
allow => qr/^\d+$/, |
67
|
|
|
|
|
|
|
}, |
68
|
|
|
|
|
|
|
testkey6 => { |
69
|
|
|
|
|
|
|
allow => qr/^\w+$/, |
70
|
|
|
|
|
|
|
}, |
71
|
|
|
|
|
|
|
}, |
72
|
|
|
|
|
|
|
], |
73
|
|
|
|
|
|
|
); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub subalso { |
77
|
|
|
|
|
|
|
my (%params) = @_; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
### Checks parameters agains profile of subroto and above registered |
80
|
|
|
|
|
|
|
### profile |
81
|
|
|
|
|
|
|
return unlesss Params::Profile->validate('params' => \%params); |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
### DO SOME STUFF HERE ... |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=head1 DESCRIPTION |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Params::Profile provides a mechanism for a centralised Params::Check or a |
90
|
|
|
|
|
|
|
Data::FormValidater profile. You can bind a profile to a class::subroutine, |
91
|
|
|
|
|
|
|
then, when you are in a subroutine you can simply call |
92
|
|
|
|
|
|
|
Params::Profile->check($params) of Params::Profile->validate($params) to |
93
|
|
|
|
|
|
|
validate against this profile. Validate will return true or false on |
94
|
|
|
|
|
|
|
successfull or failed validation. Check will return what C<Data::FormValidator> |
95
|
|
|
|
|
|
|
or C<Params::Check> would return. (For C<Params::Check> this is simply a hash |
96
|
|
|
|
|
|
|
with the validated parameters , for C<Data::FormValidator>, this is a |
97
|
|
|
|
|
|
|
C<Data::FormValidator::Results> object) |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head1 Object Methods |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=head2 Params::Profile->register_profile('method' => $method, 'profile' => |
102
|
|
|
|
|
|
|
$profile [, caller => $callerclass ) |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Register a new profile for method for the called-from caller class. Instead of |
105
|
|
|
|
|
|
|
a profile, you could give a STRING containing the method from which you want to |
106
|
|
|
|
|
|
|
use the profile...or simpler saying: make an alias to a profile. You can also |
107
|
|
|
|
|
|
|
give an ARRAYREF containing both strings (defining the aliases) and HASHREFS, |
108
|
|
|
|
|
|
|
defining profiles which then will be combined (See second example in SYNOPSYS). |
109
|
|
|
|
|
|
|
When you provide the optional caller option, you define the class where the |
110
|
|
|
|
|
|
|
given method is defined. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=cut |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub register_profile { |
115
|
9
|
|
|
9
|
1
|
1191
|
my ($class, %args) = @_; |
116
|
9
|
|
|
|
|
13
|
my ($method, $new_profiles, $caller, @profiles, $type); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
my $tpl = { |
119
|
|
|
|
|
|
|
method => { |
120
|
|
|
|
|
|
|
required => 1, |
121
|
|
|
|
|
|
|
store => \$method, |
122
|
|
|
|
|
|
|
}, |
123
|
|
|
|
|
|
|
profile => { |
124
|
|
|
|
|
|
|
required => 1, |
125
|
|
|
|
|
|
|
### Allow hashref or plain text defining alias, |
126
|
|
|
|
|
|
|
allow => sub { |
127
|
9
|
50
|
100
|
9
|
|
881
|
UNIVERSAL::isa($_[0], 'HASH') || |
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
128
|
|
|
|
|
|
|
UNIVERSAL::isa($_[0], 'ARRAY') || |
129
|
|
|
|
|
|
|
!ref($_[0]) || $_[0] eq NO_ARGS |
130
|
|
|
|
|
|
|
|| $_[0] eq NO_PROFILE |
131
|
|
|
|
|
|
|
}, |
132
|
9
|
|
|
|
|
92
|
store => \$new_profiles, |
133
|
|
|
|
|
|
|
}, |
134
|
|
|
|
|
|
|
'caller' => { |
135
|
|
|
|
|
|
|
required => 0, |
136
|
|
|
|
|
|
|
allow => qr/^[\w0-9:-]+$/, |
137
|
|
|
|
|
|
|
default => $class->_get_caller_class, |
138
|
|
|
|
|
|
|
store => \$caller, |
139
|
|
|
|
|
|
|
}, |
140
|
|
|
|
|
|
|
}; |
141
|
|
|
|
|
|
|
|
142
|
9
|
50
|
|
|
|
51
|
Params::Check::check($tpl, \%args) or ( |
143
|
|
|
|
|
|
|
$class->_raise_warning('Failed validating input parameters'), |
144
|
|
|
|
|
|
|
return |
145
|
|
|
|
|
|
|
); |
146
|
|
|
|
|
|
|
|
147
|
9
|
|
|
|
|
291
|
my $subname = $class->_full_method_name( $method, $caller ); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
### Create an array of profiles for easyer checking |
150
|
9
|
100
|
|
|
|
41
|
@profiles = UNIVERSAL::isa($new_profiles, 'ARRAY') ? @$new_profiles : ($new_profiles); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
### Check given profiles |
153
|
9
|
|
|
|
|
29
|
for (my $i=0; $i<@profiles; $i++) { |
154
|
|
|
|
|
|
|
### Check if alias exists |
155
|
13
|
100
|
66
|
|
|
82
|
if (!ref($profiles[$i]) && !__PACKAGE__->Profiles->{ |
156
|
|
|
|
|
|
|
$class->_full_method_name( $profiles[$i], $caller ) |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
) { |
159
|
1
|
|
|
|
|
5
|
$class->_raise_warning ( |
160
|
|
|
|
|
|
|
'Cannot alias (' . $subname . ') to missing profile: ' |
161
|
|
|
|
|
|
|
. $class->_full_method_name( $profiles[$i], $caller )); |
162
|
1
|
|
|
|
|
33
|
return; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
### Check if profiles match the chosen validator system (DV or PC) |
166
|
12
|
100
|
|
|
|
30
|
if (ref($profiles[$i])) { |
167
|
10
|
100
|
66
|
|
|
73
|
if ( |
168
|
|
|
|
|
|
|
UNIVERSAL::isa($profiles[$i]->{required},'ARRAY') || |
169
|
|
|
|
|
|
|
UNIVERSAL::isa($profiles[$i]->{optional},'ARRAY') |
170
|
|
|
|
|
|
|
) { |
171
|
|
|
|
|
|
|
( |
172
|
6
|
100
|
100
|
|
|
27
|
$class->_raise_warning ( |
173
|
|
|
|
|
|
|
'Profile type clash for: ' |
174
|
|
|
|
|
|
|
. $method |
175
|
|
|
|
|
|
|
), |
176
|
|
|
|
|
|
|
return |
177
|
|
|
|
|
|
|
) if ($type && $type ne 'dv'); |
178
|
5
|
|
|
|
|
11
|
$type = 'dv'; |
179
|
|
|
|
|
|
|
} else { |
180
|
|
|
|
|
|
|
( |
181
|
4
|
50
|
66
|
|
|
18
|
$class->_raise_warning ( |
182
|
|
|
|
|
|
|
'Profile type clash for: ' |
183
|
|
|
|
|
|
|
. $class->_full_method_name($profiles[$i], $caller) |
184
|
|
|
|
|
|
|
), |
185
|
|
|
|
|
|
|
return |
186
|
|
|
|
|
|
|
) if ($type && $type ne 'pc'); |
187
|
4
|
|
|
|
|
8
|
$type = 'pc'; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
### Set full name on aliases |
192
|
11
|
100
|
|
|
|
45
|
$profiles[$i] = $class->_full_method_name( |
193
|
|
|
|
|
|
|
$profiles[$i], |
194
|
|
|
|
|
|
|
$class->_get_caller_class |
195
|
|
|
|
|
|
|
) if !ref($profiles[$i]); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
### Joy, all went fine, let's register this profile |
199
|
7
|
|
|
|
|
40
|
__PACKAGE__->Profiles->{$subname} = { type => $type, |
200
|
|
|
|
|
|
|
profiles => \@profiles, |
201
|
|
|
|
|
|
|
}; |
202
|
|
|
|
|
|
|
|
203
|
7
|
|
|
|
|
119
|
return 1; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub _full_method_name { |
208
|
27
|
|
|
27
|
|
55
|
my $class = shift; |
209
|
27
|
|
|
|
|
33
|
my $method = shift; |
210
|
27
|
|
66
|
|
|
67
|
my $caller = shift || $class->_get_caller_class; |
211
|
|
|
|
|
|
|
|
212
|
27
|
100
|
|
|
|
93
|
$method = $method =~ /::/ |
213
|
|
|
|
|
|
|
? $method |
214
|
|
|
|
|
|
|
: join( '::', $caller, $method ); |
215
|
|
|
|
|
|
|
|
216
|
27
|
|
|
|
|
103
|
return $method; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
=head2 Params::Profile->get_profile( method => $method [, caller => $caller ]); |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
Returns the profile registered for $method, or when no $method is given, |
222
|
|
|
|
|
|
|
returns the profile for caller. |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=cut |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub get_profile { |
227
|
4
|
|
|
4
|
1
|
1507
|
my ($class, %args) = @_; |
228
|
4
|
|
|
|
|
6
|
my ($method, $caller); |
229
|
|
|
|
|
|
|
|
230
|
4
|
|
|
|
|
27
|
my $tpl = { |
231
|
|
|
|
|
|
|
method => { |
232
|
|
|
|
|
|
|
required => 1, |
233
|
|
|
|
|
|
|
store => \$method, |
234
|
|
|
|
|
|
|
}, |
235
|
|
|
|
|
|
|
'caller' => { |
236
|
|
|
|
|
|
|
required => 0, |
237
|
|
|
|
|
|
|
allow => qr/^[\w0-9:-]+$/, |
238
|
|
|
|
|
|
|
default => $class->_get_caller_class, |
239
|
|
|
|
|
|
|
store => \$caller, |
240
|
|
|
|
|
|
|
}, |
241
|
|
|
|
|
|
|
}; |
242
|
|
|
|
|
|
|
|
243
|
4
|
50
|
|
|
|
23
|
Params::Check::check($tpl, \%args) or ($class->_raise_warning('Failed validating input parameters'), return); |
244
|
4
|
|
|
|
|
339
|
return $class->_get_profile( |
245
|
|
|
|
|
|
|
$class->_full_method_name( $method, $caller ) |
246
|
|
|
|
|
|
|
); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=head2 Params::Profile->verify_profiles( \@methods ); |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
Verifies for each method in list, if the profile exists. Returns undef |
252
|
|
|
|
|
|
|
when it doesn't. Also checks for aliases which point to no existing |
253
|
|
|
|
|
|
|
profiles. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
=cut |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
sub verify_profiles { |
258
|
1
|
|
|
1
|
1
|
32
|
my $class = shift; |
259
|
1
|
50
|
|
|
|
4
|
my @methods = @_ ? @_ : keys %{ __PACKAGE__->Profiles }; |
|
1
|
|
|
|
|
5
|
|
260
|
|
|
|
|
|
|
|
261
|
1
|
|
|
|
|
8
|
my $fail; |
262
|
1
|
|
|
|
|
2
|
for my $method ( @methods ) { |
263
|
2
|
|
|
|
|
6
|
my $profile = $class->get_profile( method => $method ); |
264
|
|
|
|
|
|
|
|
265
|
2
|
50
|
|
|
|
9
|
$fail++ unless $profile; |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
### XXX validate the profile? |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
1
|
50
|
|
|
|
5
|
return if $fail; |
271
|
1
|
|
|
|
|
5
|
return 1; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub _get_profile { |
275
|
15
|
|
|
15
|
|
45
|
my ($class, $method) = @_; |
276
|
15
|
|
|
|
|
17
|
my (%profile,@profiles); |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
### No profile exists |
279
|
15
|
50
|
|
|
|
40
|
unless ( exists __PACKAGE__->Profiles->{ $method } ) { |
280
|
0
|
|
|
|
|
0
|
$class->_raise_warning( "No profile for '$method'" ); |
281
|
0
|
|
|
|
|
0
|
return; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
### Alias of another profile |
285
|
15
|
100
|
|
|
|
181
|
if ( !__PACKAGE__->Profiles->{$method}->{type} ) { |
286
|
|
|
|
|
|
|
### return profile of alias |
287
|
1
|
|
|
|
|
9
|
return $class->_get_profile( |
288
|
|
|
|
|
|
|
__PACKAGE__->Profiles->{$method}->{profiles}->[0] |
289
|
|
|
|
|
|
|
); |
290
|
|
|
|
|
|
|
} else { |
291
|
|
|
|
|
|
|
### Create array of profiles for easyer handling |
292
|
14
|
|
|
|
|
34
|
push(@profiles, !ref($_) ? |
293
|
|
|
|
|
|
|
$class->_get_profile( |
294
|
|
|
|
|
|
|
$_ |
295
|
|
|
|
|
|
|
) : $_ |
296
|
14
|
100
|
|
|
|
127
|
) for (@{ __PACKAGE__->Profiles->{$method}->{'profiles'} }); |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
### No alias, return profile |
299
|
14
|
100
|
|
|
|
130
|
if (__PACKAGE__->Profiles->{$method}->{type} eq 'dv') { |
300
|
11
|
|
|
|
|
138
|
return $Mod_DV->get_profile( |
301
|
|
|
|
|
|
|
$method, |
302
|
|
|
|
|
|
|
@profiles, |
303
|
|
|
|
|
|
|
); |
304
|
|
|
|
|
|
|
} else { |
305
|
3
|
|
|
|
|
31
|
return $Mod_PC->get_profile( |
306
|
|
|
|
|
|
|
$method, |
307
|
|
|
|
|
|
|
@profiles, |
308
|
|
|
|
|
|
|
); |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
} |
311
|
0
|
|
|
|
|
0
|
return; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
=head2 Params::Profile->clear_profiles(); |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
Clear the loaded profiles. |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
=cut |
319
|
|
|
|
|
|
|
|
320
|
0
|
|
|
0
|
1
|
0
|
sub clear_profiles { __PACKAGE__->Profiles({}); return 1; } |
|
0
|
|
|
|
|
0
|
|
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
=head2 Params::Profile->get_profiles() |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
Just return a hash containing all the registered profiles, it is in the form: |
325
|
|
|
|
|
|
|
method => [ \%profile ] |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
=cut |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
0
|
1
|
0
|
sub get_profiles { return __PACKAGE__->Profiles; } |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
=head2 Params::Profile->validate( params => %params [, method => $method ] ) |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
When given an hash of key->value pairs, this sub will check the values against |
334
|
|
|
|
|
|
|
the loaded profile. Returns true when it validates, otherwise returns false. |
335
|
|
|
|
|
|
|
It will check against the loaded profile for the given method, or when method |
336
|
|
|
|
|
|
|
doesn't exist, against the caller |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=cut |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub validate { |
341
|
5
|
|
|
5
|
1
|
1487
|
my ($class, %args) = @_; |
342
|
5
|
|
|
|
|
7
|
my ($params, $method); |
343
|
|
|
|
|
|
|
|
344
|
5
|
|
|
|
|
34
|
my $tpl = { |
345
|
|
|
|
|
|
|
'params' => { |
346
|
|
|
|
|
|
|
required => 1, |
347
|
|
|
|
|
|
|
store => \$params, |
348
|
|
|
|
|
|
|
}, |
349
|
|
|
|
|
|
|
'method' => { |
350
|
|
|
|
|
|
|
required => 0, |
351
|
|
|
|
|
|
|
allow => qr/^[\w0-9:-]+$/, |
352
|
|
|
|
|
|
|
default => |
353
|
|
|
|
|
|
|
$class->_full_method_name( |
354
|
|
|
|
|
|
|
$class->_get_caller_method |
355
|
|
|
|
|
|
|
), |
356
|
|
|
|
|
|
|
store => \$method, |
357
|
|
|
|
|
|
|
}, |
358
|
|
|
|
|
|
|
}; |
359
|
|
|
|
|
|
|
|
360
|
5
|
50
|
|
|
|
24
|
Params::Check::check($tpl, \%args) or ( |
361
|
|
|
|
|
|
|
$class->_raise_warning('Failed validating input parameters'), |
362
|
|
|
|
|
|
|
return |
363
|
|
|
|
|
|
|
); |
364
|
|
|
|
|
|
|
|
365
|
5
|
50
|
|
|
|
381
|
my $profile = $class->_get_profile($method) or return; |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
### Data::FormValidator or Params::Check template |
368
|
5
|
|
|
|
|
8
|
my ($ok, $vclass); |
369
|
5
|
100
|
66
|
|
|
33
|
if ( |
370
|
|
|
|
|
|
|
UNIVERSAL::isa($profile->{required},'ARRAY') || |
371
|
|
|
|
|
|
|
UNIVERSAL::isa($profile->{optional},'ARRAY') |
372
|
|
|
|
|
|
|
) { |
373
|
|
|
|
|
|
|
### Data::FormValidator |
374
|
4
|
|
|
|
|
6
|
$ok = $Mod_DV->check($params, %{ $profile })->success; |
|
4
|
|
|
|
|
21
|
|
375
|
|
|
|
|
|
|
} else { |
376
|
1
|
50
|
|
|
|
4
|
$ok = Params::Check::check($profile, $params) ? 1 : 0; |
377
|
|
|
|
|
|
|
} |
378
|
5
|
|
|
|
|
3158
|
return $ok; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head2 Params::Profile->check( params => %params [, method => $method ] ) |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
When given an hash of key->value pairs, this sub will check the values against |
384
|
|
|
|
|
|
|
the loaded profile. It will check against the loaded profile for the given |
385
|
|
|
|
|
|
|
method, or when method doesn't exist, against the caller. |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
Depending on the used profile, it will return %hash with values for a |
388
|
|
|
|
|
|
|
Params::Check profile. Or an object Data::FormValidator::Results when the |
389
|
|
|
|
|
|
|
laoded profile is a Data::FormValidator profile. |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=cut |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
sub check { |
394
|
3
|
|
|
3
|
1
|
9
|
my ($class, %args) = @_; |
395
|
3
|
|
|
|
|
5
|
my ($params, $method); |
396
|
|
|
|
|
|
|
|
397
|
3
|
|
|
|
|
22
|
my $tpl = { |
398
|
|
|
|
|
|
|
'params' => { |
399
|
|
|
|
|
|
|
required => 1, |
400
|
|
|
|
|
|
|
store => \$params, |
401
|
|
|
|
|
|
|
}, |
402
|
|
|
|
|
|
|
'method' => { |
403
|
|
|
|
|
|
|
required => 0, |
404
|
|
|
|
|
|
|
allow => qr/^[\w0-9:-]+$/, |
405
|
|
|
|
|
|
|
default => |
406
|
|
|
|
|
|
|
$class->_full_method_name( |
407
|
|
|
|
|
|
|
$class->_get_caller_method, |
408
|
|
|
|
|
|
|
), |
409
|
|
|
|
|
|
|
store => \$method, |
410
|
|
|
|
|
|
|
}, |
411
|
|
|
|
|
|
|
}; |
412
|
|
|
|
|
|
|
|
413
|
3
|
50
|
|
|
|
17
|
Params::Check::check($tpl, \%args) or ( |
414
|
|
|
|
|
|
|
$class->_raise_warning('Failed validating input parameters'), |
415
|
|
|
|
|
|
|
return |
416
|
|
|
|
|
|
|
); |
417
|
|
|
|
|
|
|
|
418
|
3
|
50
|
|
|
|
311
|
my $profile = $class->_get_profile($method) or return; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
### Data::FormValidator or Params::Check template |
421
|
3
|
|
|
|
|
6
|
my ($ok, $vclass); |
422
|
3
|
100
|
66
|
|
|
26
|
if ( |
423
|
|
|
|
|
|
|
UNIVERSAL::isa($profile->{required},'ARRAY') || |
424
|
|
|
|
|
|
|
UNIVERSAL::isa($profile->{optional},'ARRAY') |
425
|
|
|
|
|
|
|
) { |
426
|
|
|
|
|
|
|
### Data::FormValidator |
427
|
2
|
|
|
|
|
5
|
return $Mod_DV->check($params, %{ $profile }) |
|
2
|
|
|
|
|
10
|
|
428
|
|
|
|
|
|
|
#return Data::FormValidator->check($params, $profile); |
429
|
|
|
|
|
|
|
} else { |
430
|
|
|
|
|
|
|
### Params::Check |
431
|
1
|
|
|
|
|
2
|
return $Mod_PC->check($params, %{ $profile }); |
|
1
|
|
|
|
|
5
|
|
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub _raise_warning { |
436
|
0
|
|
|
0
|
|
0
|
my ($self, $warning) = @_; |
437
|
0
|
|
|
|
|
0
|
warn($warning); |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
23
|
|
|
23
|
|
344
|
sub _get_caller_class { return [caller(1)]->[0]; } |
441
|
|
|
|
|
|
|
|
442
|
8
|
50
|
|
8
|
|
77
|
sub _get_caller_method { return caller(2) ? [caller(2)]->[3] : ''; } |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
1; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head1 AUTHOR |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
This module by |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
Michiel Ootjers E<lt>michiel@cpan.orgE<gt>. |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
and |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
Jos Boumans E<lt>kane@cpan.orgE<gt>. |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
Thanks to Jos Boumans for C<Params::Check>, and the authors of |
459
|
|
|
|
|
|
|
C<Data::FormValidator> |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=head1 COPYRIGHT |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
This module is |
464
|
|
|
|
|
|
|
copyright (c) 2002 Michiel Ootjers E<lt>michiel@cpan.orgE<gt>. |
465
|
|
|
|
|
|
|
All rights reserved. |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
This library is free software; |
468
|
|
|
|
|
|
|
you may redistribute and/or modify it under the same |
469
|
|
|
|
|
|
|
terms as Perl itself. |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=cut |