source: rdnap/lib/Params/ValidatePP.pm@ 203

Last change on this file since 203 was 203, checked in by Rick van der Zwet, 14 years ago

Little wrapper, as, the orginal one is gone.

File size: 19.0 KB
Line 
1package Params::Validate;
2
3use strict;
4use warnings;
5
6use Scalar::Util ();
7
8# suppress subroutine redefined warnings if we tried to load the XS
9# version and failed.
10no warnings 'redefine';
11
12BEGIN {
13 sub SCALAR () {1}
14 sub ARRAYREF () {2}
15 sub HASHREF () {4}
16 sub CODEREF () {8}
17 sub GLOB () {16}
18 sub GLOBREF () {32}
19 sub SCALARREF () {64}
20 sub UNKNOWN () {128}
21 sub UNDEF () {256}
22 sub OBJECT () {512}
23
24 sub HANDLE () { 16 | 32 }
25 sub BOOLEAN () { 1 | 256 }
26}
27
28# Various internals notes (for me and any future readers of this
29# monstrosity):
30#
31# - A lot of the weirdness is _intentional_, because it optimizes for
32# the _success_ case. It does not really matter how slow the code is
33# after it enters a path that leads to reporting failure. But the
34# "success" path should be as fast as possible.
35#
36# -- We only calculate $called as needed for this reason, even though it
37# means copying code all over.
38#
39# - All the validation routines need to be careful never to alter the
40# references that are passed.
41#
42# -- The code assumes that _most_ callers will not be using the
43# skip_leading or ignore_case features. In order to not alter the
44# references passed in, we copy them wholesale when normalizing them
45# to make these features work. This is slower but lets us be faster
46# when not using them.
47
48# Matt Sergeant came up with this prototype, which slickly takes the
49# first array (which should be the caller's @_), and makes it a
50# reference. Everything after is the parameters for validation.
51sub validate_pos (\@@) {
52 return if $NO_VALIDATION && !defined wantarray;
53
54 my $p = shift;
55
56 my @specs = @_;
57
58 my @p = @$p;
59 if ($NO_VALIDATION) {
60
61 # if the spec is bigger that's where we can start adding
62 # defaults
63 for ( my $x = $#p + 1; $x <= $#specs; $x++ ) {
64 $p[$x] = $specs[$x]->{default}
65 if ref $specs[$x] && exists $specs[$x]->{default};
66 }
67
68 return wantarray ? @p : \@p;
69 }
70
71 # I'm too lazy to pass these around all over the place.
72 local $options ||= _get_options( ( caller(0) )[0] )
73 unless defined $options;
74
75 my $min = 0;
76
77 while (1) {
78 last
79 unless (
80 ref $specs[$min]
81 ? !( exists $specs[$min]->{default} || $specs[$min]->{optional} )
82 : $specs[$min]
83 );
84
85 $min++;
86 }
87
88 my $max = scalar @specs;
89
90 my $actual = scalar @p;
91 unless ( $actual >= $min
92 && ( $options->{allow_extra} || $actual <= $max ) ) {
93 my $minmax = (
94 $options->{allow_extra}
95 ? "at least $min"
96 : ( $min != $max ? "$min - $max" : $max )
97 );
98
99 my $val = $options->{allow_extra} ? $min : $max;
100 $minmax .= $val != 1 ? ' were' : ' was';
101
102 my $called = _get_called();
103
104 $options->{on_fail}->( "$actual parameter"
105 . ( $actual != 1 ? 's' : '' ) . " "
106 . ( $actual != 1 ? 'were' : 'was' )
107 . " passed to $called but $minmax expected\n" );
108 }
109
110 my $bigger = $#p > $#specs ? $#p : $#specs;
111 foreach ( 0 .. $bigger ) {
112 my $spec = $specs[$_];
113
114 next unless ref $spec;
115
116 if ( $_ <= $#p ) {
117 my $value = defined $p[$_] ? qq|"$p[$_]"| : 'undef';
118 _validate_one_param( $p[$_], \@p, $spec,
119 "Parameter #" . ( $_ + 1 ) . " ($value)" );
120 }
121
122 $p[$_] = $spec->{default} if $_ > $#p && exists $spec->{default};
123 }
124
125 _validate_pos_depends( \@p, \@specs );
126
127 foreach (
128 grep {
129 defined $p[$_]
130 && !ref $p[$_]
131 && ref $specs[$_]
132 && $specs[$_]{untaint}
133 } 0 .. $bigger
134 ) {
135 ( $p[$_] ) = $p[$_] =~ /(.+)/;
136 }
137
138 return wantarray ? @p : \@p;
139}
140
141sub _validate_pos_depends {
142 my ( $p, $specs ) = @_;
143
144 for my $p_idx ( 0 .. $#$p ) {
145 my $spec = $specs->[$p_idx];
146
147 next
148 unless $spec
149 && UNIVERSAL::isa( $spec, 'HASH' )
150 && exists $spec->{depends};
151
152 my $depends = $spec->{depends};
153
154 if ( ref $depends ) {
155 require Carp;
156 local $Carp::CarpLevel = 2;
157 Carp::croak(
158 "Arguments to 'depends' for validate_pos() must be a scalar");
159 }
160
161 my $p_size = scalar @$p;
162 if ( $p_size < $depends - 1 ) {
163 my $error
164 = ( "Parameter #"
165 . ( $p_idx + 1 )
166 . " depends on parameter #"
167 . $depends
168 . ", which was not given" );
169
170 $options->{on_fail}->($error);
171 }
172 }
173 return 1;
174}
175
176sub _validate_named_depends {
177 my ( $p, $specs ) = @_;
178
179 foreach my $pname ( keys %$p ) {
180 my $spec = $specs->{$pname};
181
182 next
183 unless $spec
184 && UNIVERSAL::isa( $spec, 'HASH' )
185 && $spec->{depends};
186
187 unless ( UNIVERSAL::isa( $spec->{depends}, 'ARRAY' )
188 || !ref $spec->{depends} ) {
189 require Carp;
190 local $Carp::CarpLevel = 2;
191 Carp::croak(
192 "Arguments to 'depends' must be a scalar or arrayref");
193 }
194
195 foreach my $depends_name (
196 ref $spec->{depends}
197 ? @{ $spec->{depends} }
198 : $spec->{depends}
199 ) {
200 unless ( exists $p->{$depends_name} ) {
201 my $error
202 = ( "Parameter '$pname' depends on parameter '"
203 . $depends_name
204 . "', which was not given" );
205
206 $options->{on_fail}->($error);
207 }
208 }
209 }
210}
211
212sub validate (\@$) {
213 return if $NO_VALIDATION && !defined wantarray;
214
215 my $p = $_[0];
216
217 my $specs = $_[1];
218 local $options = _get_options( ( caller(0) )[0] ) unless defined $options;
219
220 if ( ref $p eq 'ARRAY' ) {
221
222 # we were called as validate( @_, ... ) where @_ has a
223 # single element, a hash reference
224 if ( ref $p->[0] ) {
225 $p = { %{ $p->[0] } };
226 }
227 elsif ( @$p % 2 ) {
228 my $called = _get_called();
229
230 $options->{on_fail}
231 ->( "Odd number of parameters in call to $called "
232 . "when named parameters were expected\n" );
233 }
234 else {
235 $p = {@$p};
236 }
237 }
238
239 if ( $options->{normalize_keys} ) {
240 $specs = _normalize_callback( $specs, $options->{normalize_keys} );
241 $p = _normalize_callback( $p, $options->{normalize_keys} );
242 }
243 elsif ( $options->{ignore_case} || $options->{strip_leading} ) {
244 $specs = _normalize_named($specs);
245 $p = _normalize_named($p);
246 }
247
248 if ($NO_VALIDATION) {
249 return (
250 wantarray
251 ? (
252
253 # this is a hash containing just the defaults
254 (
255 map { $_ => $specs->{$_}->{default} }
256 grep {
257 ref $specs->{$_} && exists $specs->{$_}->{default}
258 }
259 keys %$specs
260 ),
261 (
262 ref $p eq 'ARRAY'
263 ? (
264 ref $p->[0]
265 ? %{ $p->[0] }
266 : @$p
267 )
268 : %$p
269 )
270 )
271 : do {
272 my $ref = (
273 ref $p eq 'ARRAY'
274 ? (
275 ref $p->[0]
276 ? $p->[0]
277 : {@$p}
278 )
279 : $p
280 );
281
282 foreach (
283 grep {
284 ref $specs->{$_}
285 && exists $specs->{$_}->{default}
286 }
287 keys %$specs
288 ) {
289 $ref->{$_} = $specs->{$_}->{default}
290 unless exists $ref->{$_};
291 }
292
293 return $ref;
294 }
295 );
296 }
297
298 _validate_named_depends( $p, $specs );
299
300 unless ( $options->{allow_extra} ) {
301 if ( my @unmentioned = grep { !exists $specs->{$_} } keys %$p ) {
302 my $called = _get_called();
303
304 $options->{on_fail}->( "The following parameter"
305 . ( @unmentioned > 1 ? 's were' : ' was' )
306 . " passed in the call to $called but "
307 . ( @unmentioned > 1 ? 'were' : 'was' )
308 . " not listed in the validation options: @unmentioned\n"
309 );
310 }
311 }
312
313 my @missing;
314
315 # the iterator needs to be reset in case the same hashref is being
316 # passed to validate() on successive calls, because we may not go
317 # through all the hash's elements
318 keys %$specs;
319OUTER:
320 while ( my ( $key, $spec ) = each %$specs ) {
321 if (
322 !exists $p->{$key}
323 && (
324 ref $spec
325 ? !(
326 do {
327
328 # we want to short circuit the loop here if we
329 # can assign a default, because there's no need
330 # check anything else at all.
331 if ( exists $spec->{default} ) {
332 $p->{$key} = $spec->{default};
333 next OUTER;
334 }
335 }
336 || do {
337
338 # Similarly, an optional parameter that is
339 # missing needs no additional processing.
340 next OUTER if $spec->{optional};
341 }
342 )
343 : $spec
344 )
345 ) {
346 push @missing, $key;
347 }
348
349 # Can't validate a non hashref spec beyond the presence or
350 # absence of the parameter.
351 elsif ( ref $spec ) {
352 my $value = defined $p->{$key} ? qq|"$p->{$key}"| : 'undef';
353 _validate_one_param( $p->{$key}, $p, $spec,
354 "The '$key' parameter ($value)" );
355 }
356 }
357
358 if (@missing) {
359 my $called = _get_called();
360
361 my $missing = join ', ', map {"'$_'"} @missing;
362 $options->{on_fail}->( "Mandatory parameter"
363 . ( @missing > 1 ? 's' : '' )
364 . " $missing missing in call to $called\n" );
365 }
366
367 # do untainting after we know everything passed
368 foreach my $key (
369 grep {
370 defined $p->{$_}
371 && !ref $p->{$_}
372 && ref $specs->{$_}
373 && $specs->{$_}{untaint}
374 }
375 keys %$p
376 ) {
377 ( $p->{$key} ) = $p->{$key} =~ /(.+)/;
378 }
379
380 return wantarray ? %$p : $p;
381}
382
383sub validate_with {
384 return if $NO_VALIDATION && !defined wantarray;
385
386 my %p = @_;
387
388 local $options = _get_options( ( caller(0) )[0], %p );
389
390 unless ($NO_VALIDATION) {
391 unless ( exists $options->{called} ) {
392 $options->{called} = ( caller( $options->{stack_skip} ) )[3];
393 }
394
395 }
396
397 if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) {
398 return validate_pos( @{ $p{params} }, @{ $p{spec} } );
399 }
400 else {
401
402 # intentionally ignore the prototype because this contains
403 # either an array or hash reference, and validate() will
404 # handle either one properly
405 return &validate( $p{params}, $p{spec} );
406 }
407}
408
409sub _normalize_callback {
410 my ( $p, $func ) = @_;
411
412 my %new;
413
414 foreach my $key ( keys %$p ) {
415 my $new_key = $func->($key);
416
417 unless ( defined $new_key ) {
418 die
419 "The normalize_keys callback did not return a defined value when normalizing the key '$key'";
420 }
421
422 if ( exists $new{$new_key} ) {
423 die
424 "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'";
425 }
426
427 $new{$new_key} = $p->{$key};
428 }
429
430 return \%new;
431}
432
433sub _normalize_named {
434
435 # intentional copy so we don't destroy original
436 my %h = ( ref $_[0] ) =~ /ARRAY/ ? @{ $_[0] } : %{ $_[0] };
437
438 if ( $options->{ignore_case} ) {
439 $h{ lc $_ } = delete $h{$_} for keys %h;
440 }
441
442 if ( $options->{strip_leading} ) {
443 foreach my $key ( keys %h ) {
444 my $new;
445 ( $new = $key ) =~ s/^\Q$options->{strip_leading}\E//;
446 $h{$new} = delete $h{$key};
447 }
448 }
449
450 return \%h;
451}
452
453sub _validate_one_param {
454 my ( $value, $params, $spec, $id ) = @_;
455
456 if ( exists $spec->{type} ) {
457 unless ( defined $spec->{type}
458 && Scalar::Util::looks_like_number( $spec->{type} )
459 && $spec->{type} > 0 ) {
460 my $msg
461 = "$id has a type specification which is not a number. It is ";
462 if ( defined $spec->{type} ) {
463 $msg .= "a string - $spec->{type}";
464 }
465 else {
466 $msg .= "undef";
467 }
468
469 $msg
470 .= ".\n Use the constants exported by Params::Validate to declare types.";
471
472 $options->{on_fail}->($msg);
473 }
474
475 unless ( _get_type($value) & $spec->{type} ) {
476 my $type = _get_type($value);
477
478 my @is = _typemask_to_strings($type);
479 my @allowed = _typemask_to_strings( $spec->{type} );
480 my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a';
481
482 my $called = _get_called(1);
483
484 $options->{on_fail}->( "$id to $called was $article '@is', which "
485 . "is not one of the allowed types: @allowed\n" );
486 }
487 }
488
489 # short-circuit for common case
490 return
491 unless ( $spec->{isa}
492 || $spec->{can}
493 || $spec->{callbacks}
494 || $spec->{regex} );
495
496 if ( exists $spec->{isa} ) {
497 foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} ) {
498 unless ( eval { $value->isa($_) } ) {
499 my $is = ref $value ? ref $value : 'plain scalar';
500 my $article1 = $_ =~ /^[aeiou]/i ? 'an' : 'a';
501 my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a';
502
503 my $called = _get_called(1);
504
505 $options->{on_fail}
506 ->( "$id to $called was not $article1 '$_' "
507 . "(it is $article2 $is)\n" );
508 }
509 }
510 }
511
512 if ( exists $spec->{can} ) {
513 foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} ) {
514 unless ( eval { $value->can($_) } ) {
515 my $called = _get_called(1);
516
517 $options->{on_fail}
518 ->("$id to $called does not have the method: '$_'\n");
519 }
520 }
521 }
522
523 if ( $spec->{callbacks} ) {
524 unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) ) {
525 my $called = _get_called(1);
526
527 $options->{on_fail}->(
528 "'callbacks' validation parameter for $called must be a hash reference\n"
529 );
530 }
531
532 foreach ( keys %{ $spec->{callbacks} } ) {
533 unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) ) {
534 my $called = _get_called(1);
535
536 $options->{on_fail}->(
537 "callback '$_' for $called is not a subroutine reference\n"
538 );
539 }
540
541 unless ( $spec->{callbacks}{$_}->( $value, $params ) ) {
542 my $called = _get_called(1);
543
544 $options->{on_fail}
545 ->("$id to $called did not pass the '$_' callback\n");
546 }
547 }
548 }
549
550 if ( exists $spec->{regex} ) {
551 unless ( ( defined $value ? $value : '' ) =~ /$spec->{regex}/ ) {
552 my $called = _get_called(1);
553
554 $options->{on_fail}
555 ->("$id to $called did not pass regex check\n");
556 }
557 }
558}
559
560{
561
562 # if it UNIVERSAL::isa the string on the left then its the type on
563 # the right
564 my %isas = (
565 'ARRAY' => ARRAYREF,
566 'HASH' => HASHREF,
567 'CODE' => CODEREF,
568 'GLOB' => GLOBREF,
569 'SCALAR' => SCALARREF,
570 );
571 my %simple_refs = map { $_ => 1 } keys %isas;
572
573 sub _get_type {
574 return UNDEF unless defined $_[0];
575
576 my $ref = ref $_[0];
577 unless ($ref) {
578
579 # catches things like: my $fh = do { local *FH; };
580 return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' );
581 return SCALAR;
582 }
583
584 return $isas{$ref} if $simple_refs{$ref};
585
586 foreach ( keys %isas ) {
587 return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ );
588 }
589
590 # I really hope this never happens.
591 return UNKNOWN;
592 }
593}
594
595{
596 my %type_to_string = (
597 SCALAR() => 'scalar',
598 ARRAYREF() => 'arrayref',
599 HASHREF() => 'hashref',
600 CODEREF() => 'coderef',
601 GLOB() => 'glob',
602 GLOBREF() => 'globref',
603 SCALARREF() => 'scalarref',
604 UNDEF() => 'undef',
605 OBJECT() => 'object',
606 UNKNOWN() => 'unknown',
607 );
608
609 sub _typemask_to_strings {
610 my $mask = shift;
611
612 my @types;
613 foreach (
614 SCALAR, ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF,
615 SCALARREF, UNDEF, OBJECT, UNKNOWN
616 ) {
617 push @types, $type_to_string{$_} if $mask & $_;
618 }
619 return @types ? @types : ('unknown');
620 }
621}
622
623{
624 my %defaults = (
625 ignore_case => 0,
626 strip_leading => 0,
627 allow_extra => 0,
628 on_fail => sub {
629 require Carp;
630 Carp::confess( $_[0] );
631 },
632 stack_skip => 1,
633 normalize_keys => undef,
634 );
635
636 *set_options = \&validation_options;
637
638 sub validation_options {
639 my %opts = @_;
640
641 my $caller = caller;
642
643 foreach ( keys %defaults ) {
644 $opts{$_} = $defaults{$_} unless exists $opts{$_};
645 }
646
647 $OPTIONS{$caller} = \%opts;
648 }
649
650 sub _get_options {
651 my $caller = shift;
652
653 if (@_) {
654
655 return (
656 $OPTIONS{$caller}
657 ? {
658 %{ $OPTIONS{$caller} },
659 @_
660 }
661 : { %defaults, @_ }
662 );
663 }
664 else {
665 return (
666 exists $OPTIONS{$caller}
667 ? $OPTIONS{$caller}
668 : \%defaults
669 );
670 }
671 }
672}
673
674sub _get_called {
675 my $extra_skip = $_[0] || 0;
676
677 # always add one more for this sub
678 $extra_skip++;
679
680 my $called = (
681 exists $options->{called}
682 ? $options->{called}
683 : ( caller( $options->{stack_skip} + $extra_skip ) )[3]
684 );
685
686 $called = 'N/A' unless defined $called;
687
688 return $called;
689}
690
6911;
692
693__END__
694
695=head1 NAME
696
697Params::ValidatePP - pure Perl implementation of Params::Validate
698
699=head1 SYNOPSIS
700
701 See Params::Validate
702
703=head1 DESCRIPTION
704
705This is a pure Perl implementation of Params::Validate. See the
706Params::Validate documentation for details.
707
708=head1 COPYRIGHT
709
710Copyright (c) 2004-2007 David Rolsky. All rights reserved. This
711program is free software; you can redistribute it and/or modify it
712under the same terms as Perl itself.
713
714=cut
Note: See TracBrowser for help on using the repository browser.