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