local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Params/ValidatePP.pm

   1 package Params::Validate;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Scalar::Util ();
   7
   8 # suppress subroutine redefined warnings if we tried to load the XS
   9 # version and failed.
  10 no warnings 'redefine';
  11
  12 BEGIN {
  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.
  51 sub 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
 141 sub _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
 176 sub _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
 212 sub 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;
 319 OUTER:
 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
 383 sub 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
 409 sub _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
 433 sub _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
 453 sub _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
 674 sub _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
 691 1;
 692
 693 __END__
 694
 695 =head1 NAME
 696
 697 Params::ValidatePP - pure Perl implementation of Params::Validate
 698
 699 =head1 SYNOPSIS
 700
 701   See Params::Validate
 702
 703 =head1 DESCRIPTION
 704
 705 This is a pure Perl implementation of Params::Validate.  See the
 706 Params::Validate documentation for details.
 707
 708 =head1 COPYRIGHT
 709
 710 Copyright (c) 2004-2007 David Rolsky.  All rights reserved.  This
 711 program is free software; you can redistribute it and/or modify it
 712 under the same terms as Perl itself.
 713
 714 =cut