File Coverage

lib/Params/Profile.pm
Criterion Covered Total %
statement 94 102 92.1
branch 38 52 73.0
condition 21 30 70.0
subroutine 17 20 85.0
pod 7 7 100.0
total 177 211 83.8


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