ok
Direktori : /proc/thread-self/root/proc/self/root/proc/self/root/usr/local/lib64/perl5/Params/Validate/ |
Current File : //proc/thread-self/root/proc/self/root/proc/self/root/usr/local/lib64/perl5/Params/Validate/PP.pm |
package Params::Validate::PP; use strict; use warnings; our $VERSION = '1.31'; use Params::Validate::Constants; use Scalar::Util 1.10 (); our $options; # Various internals notes (for me and any future readers of this # monstrosity): # # - A lot of the weirdness is _intentional_, because it optimizes for # the _success_ case. It does not really matter how slow the code is # after it enters a path that leads to reporting failure. But the # "success" path should be as fast as possible. # # -- We only calculate $called as needed for this reason, even though it # means copying code all over. # # - All the validation routines need to be careful never to alter the # references that are passed. # # -- The code assumes that _most_ callers will not be using the # skip_leading or ignore_case features. In order to not alter the # references passed in, we copy them wholesale when normalizing them # to make these features work. This is slower but lets us be faster # when not using them. # Matt Sergeant came up with this prototype, which slickly takes the # first array (which should be the caller's @_), and makes it a # reference. Everything after is the parameters for validation. sub validate_pos (\@@) { return if $Params::Validate::NO_VALIDATION && !defined wantarray; my $p = shift; my @specs = @_; my @p = @$p; if ($Params::Validate::NO_VALIDATION) { # if the spec is bigger that's where we can start adding # defaults for ( my $x = $#p + 1; $x <= $#specs; $x++ ) { $p[$x] = $specs[$x]->{default} if ref $specs[$x] && exists $specs[$x]->{default}; } return wantarray ? @p : \@p; } # I'm too lazy to pass these around all over the place. local $options ||= _get_options( ( caller(0) )[0] ) unless defined $options; my $min = 0; while (1) { last unless ( ref $specs[$min] ? !( exists $specs[$min]->{default} || $specs[$min]->{optional} ) : $specs[$min] ); $min++; } my $max = scalar @specs; my $actual = scalar @p; unless ( $actual >= $min && ( $options->{allow_extra} || $actual <= $max ) ) { my $minmax = ( $options->{allow_extra} ? "at least $min" : ( $min != $max ? "$min - $max" : $max ) ); my $val = $options->{allow_extra} ? $min : $max; $minmax .= $val != 1 ? ' were' : ' was'; my $called = _get_called(); $options->{on_fail}->( "$actual parameter" . ( $actual != 1 ? 's' : '' ) . " " . ( $actual != 1 ? 'were' : 'was' ) . " passed to $called but $minmax expected\n" ); } my $bigger = $#p > $#specs ? $#p : $#specs; foreach ( 0 .. $bigger ) { my $spec = $specs[$_]; next unless ref $spec; if ( $_ <= $#p ) { _validate_one_param( $p[$_], \@p, $spec, 'Parameter #' . ( $_ + 1 ) . ' (%s)' ); } $p[$_] = $spec->{default} if $_ > $#p && exists $spec->{default}; } _validate_pos_depends( \@p, \@specs ); foreach ( grep { defined $p[$_] && !ref $p[$_] && ref $specs[$_] && $specs[$_]{untaint} } 0 .. $bigger ) { ( $p[$_] ) = $p[$_] =~ /(.+)/; } return wantarray ? @p : \@p; } sub _validate_pos_depends { my ( $p, $specs ) = @_; for my $p_idx ( 0 .. $#$p ) { my $spec = $specs->[$p_idx]; next unless $spec && UNIVERSAL::isa( $spec, 'HASH' ) && exists $spec->{depends}; my $depends = $spec->{depends}; if ( ref $depends ) { require Carp; local $Carp::CarpLevel = 2; Carp::croak( "Arguments to 'depends' for validate_pos() must be a scalar"); } my $p_size = scalar @$p; if ( $p_size < $depends - 1 ) { my $error = ( "Parameter #" . ( $p_idx + 1 ) . " depends on parameter #" . $depends . ", which was not given" ); $options->{on_fail}->($error); } } return 1; } sub _validate_named_depends { my ( $p, $specs ) = @_; foreach my $pname ( keys %$p ) { my $spec = $specs->{$pname}; next unless $spec && UNIVERSAL::isa( $spec, 'HASH' ) && $spec->{depends}; unless ( UNIVERSAL::isa( $spec->{depends}, 'ARRAY' ) || !ref $spec->{depends} ) { require Carp; local $Carp::CarpLevel = 2; Carp::croak( "Arguments to 'depends' must be a scalar or arrayref"); } foreach my $depends_name ( ref $spec->{depends} ? @{ $spec->{depends} } : $spec->{depends} ) { unless ( exists $p->{$depends_name} ) { my $error = ( "Parameter '$pname' depends on parameter '" . $depends_name . "', which was not given" ); $options->{on_fail}->($error); } } } } sub validate (\@$) { return if $Params::Validate::NO_VALIDATION && !defined wantarray; my $p = $_[0]; my $specs = $_[1]; local $options = _get_options( ( caller(0) )[0] ) unless defined $options; if ( ref $p eq 'ARRAY' ) { # we were called as validate( @_, ... ) where @_ has a # single element, a hash reference if ( ref $p->[0] ) { $p = { %{ $p->[0] } }; } elsif ( @$p % 2 ) { my $called = _get_called(); $options->{on_fail} ->( "Odd number of parameters in call to $called " . "when named parameters were expected\n" ); } else { $p = {@$p}; } } if ( $options->{normalize_keys} ) { $specs = _normalize_callback( $specs, $options->{normalize_keys} ); $p = _normalize_callback( $p, $options->{normalize_keys} ); } elsif ( $options->{ignore_case} || $options->{strip_leading} ) { $specs = _normalize_named($specs); $p = _normalize_named($p); } if ($Params::Validate::NO_VALIDATION) { return ( wantarray ? ( # this is a hash containing just the defaults ( map { $_ => $specs->{$_}->{default} } grep { ref $specs->{$_} && exists $specs->{$_}->{default} } keys %$specs ), ( ref $p eq 'ARRAY' ? ( ref $p->[0] ? %{ $p->[0] } : @$p ) : %$p ) ) : do { my $ref = ( ref $p eq 'ARRAY' ? ( ref $p->[0] ? $p->[0] : {@$p} ) : $p ); foreach ( grep { ref $specs->{$_} && exists $specs->{$_}->{default} } keys %$specs ) { $ref->{$_} = $specs->{$_}->{default} unless exists $ref->{$_}; } return $ref; } ); } _validate_named_depends( $p, $specs ); unless ( $options->{allow_extra} ) { if ( my @unmentioned = grep { !exists $specs->{$_} } keys %$p ) { my $called = _get_called(); $options->{on_fail}->( "The following parameter" . ( @unmentioned > 1 ? 's were' : ' was' ) . " passed in the call to $called but " . ( @unmentioned > 1 ? 'were' : 'was' ) . " not listed in the validation options: @unmentioned\n" ); } } my @missing; # the iterator needs to be reset in case the same hashref is being # passed to validate() on successive calls, because we may not go # through all the hash's elements keys %$specs; OUTER: while ( my ( $key, $spec ) = each %$specs ) { if ( !exists $p->{$key} && ( ref $spec ? !( do { # we want to short circuit the loop here if we # can assign a default, because there's no need # check anything else at all. if ( exists $spec->{default} ) { $p->{$key} = $spec->{default}; next OUTER; } } || do { # Similarly, an optional parameter that is # missing needs no additional processing. next OUTER if $spec->{optional}; } ) : $spec ) ) { push @missing, $key; } # Can't validate a non hashref spec beyond the presence or # absence of the parameter. elsif ( ref $spec ) { _validate_one_param( $p->{$key}, $p, $spec, qq{The '$key' parameter (%s)} ); } } if (@missing) { my $called = _get_called(); my $missing = join ', ', map {"'$_'"} sort @missing; $options->{on_fail}->( "Mandatory parameter" . ( @missing > 1 ? 's' : '' ) . " $missing missing in call to $called\n" ); } # do untainting after we know everything passed foreach my $key ( grep { defined $p->{$_} && !ref $p->{$_} && ref $specs->{$_} && $specs->{$_}{untaint} } keys %$p ) { ( $p->{$key} ) = $p->{$key} =~ /(.+)/; } return wantarray ? %$p : $p; } sub validate_with { return if $Params::Validate::NO_VALIDATION && !defined wantarray; my %p = @_; local $options = _get_options( ( caller(0) )[0], %p ); unless ($Params::Validate::NO_VALIDATION) { unless ( exists $options->{called} ) { $options->{called} = ( caller( $options->{stack_skip} ) )[3]; } } if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) { return validate_pos( @{ $p{params} }, @{ $p{spec} } ); } else { # intentionally ignore the prototype because this contains # either an array or hash reference, and validate() will # handle either one properly return &validate( $p{params}, $p{spec} ); } } sub _normalize_callback { my ( $p, $func ) = @_; my %new; foreach my $key ( keys %$p ) { my $new_key = $func->($key); unless ( defined $new_key ) { die "The normalize_keys callback did not return a defined value when normalizing the key '$key'"; } if ( exists $new{$new_key} ) { die "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'"; } $new{$new_key} = $p->{$key}; } return \%new; } sub _normalize_named { # intentional copy so we don't destroy original my %h = ( ref $_[0] ) =~ /ARRAY/ ? @{ $_[0] } : %{ $_[0] }; if ( $options->{ignore_case} ) { $h{ lc $_ } = delete $h{$_} for keys %h; } if ( $options->{strip_leading} ) { foreach my $key ( keys %h ) { my $new; ( $new = $key ) =~ s/^\Q$options->{strip_leading}\E//; $h{$new} = delete $h{$key}; } } return \%h; } my %Valid = map { $_ => 1 } qw( callbacks can default depends isa optional regex type untaint ); sub _validate_one_param { my ( $value, $params, $spec, $id ) = @_; # for my $key ( keys %{$spec} ) { # unless ( $Valid{$key} ) { # $options->{on_fail} # ->(qq{"$key" is not an allowed validation spec key}); # } # } if ( exists $spec->{type} ) { unless ( defined $spec->{type} && Scalar::Util::looks_like_number( $spec->{type} ) && $spec->{type} > 0 ) { my $msg = "$id has a type specification which is not a number. It is "; if ( defined $spec->{type} ) { $msg .= "a string - $spec->{type}"; } else { $msg .= "undef"; } $msg .= ".\n Use the constants exported by Params::Validate to declare types."; $options->{on_fail}->( sprintf( $msg, _stringify($value) ) ); } unless ( _get_type($value) & $spec->{type} ) { my $type = _get_type($value); my @is = _typemask_to_strings($type); my @allowed = _typemask_to_strings( $spec->{type} ); my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a'; my $called = _get_called(1); $options->{on_fail}->( sprintf( "$id to $called was $article '@is', which " . "is not one of the allowed types: @allowed\n", _stringify($value) ) ); } } # short-circuit for common case return unless ( $spec->{isa} || $spec->{can} || $spec->{callbacks} || $spec->{regex} ); if ( exists $spec->{isa} ) { foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} ) { unless ( do { local $@ = q{}; eval { $value->isa($_) }; } ) { my $is = ref $value ? ref $value : 'plain scalar'; my $article1 = $_ =~ /^[aeiou]/i ? 'an' : 'a'; my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a'; my $called = _get_called(1); $options->{on_fail}->( sprintf( "$id to $called was not $article1 '$_' " . "(it is $article2 $is)\n", _stringify($value) ) ); } } } if ( exists $spec->{can} ) { foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} ) { unless ( do { local $@ = q{}; eval { $value->can($_) }; } ) { my $called = _get_called(1); $options->{on_fail}->( sprintf( "$id to $called does not have the method: '$_'\n", _stringify($value) ) ); } } } if ( $spec->{callbacks} ) { unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) ) { my $called = _get_called(1); $options->{on_fail}->( "'callbacks' validation parameter for $called must be a hash reference\n" ); } foreach ( keys %{ $spec->{callbacks} } ) { unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) ) { my $called = _get_called(1); $options->{on_fail}->( "callback '$_' for $called is not a subroutine reference\n" ); } my $ok; my $e = do { local $@ = q{}; local $SIG{__DIE__}; $ok = eval { $spec->{callbacks}{$_}->( $value, $params ) }; $@; }; if ( !$ok ) { my $called = _get_called(1); if ( ref $e ) { $options->{on_fail}->($e); } else { my $msg = "$id to $called did not pass the '$_' callback"; $msg .= ": $e" if length $e; $msg .= "\n"; $options->{on_fail} ->( sprintf( $msg, _stringify($value) ) ); } } } } if ( exists $spec->{regex} ) { unless ( ( defined $value ? $value : '' ) =~ /$spec->{regex}/ ) { my $called = _get_called(1); $options->{on_fail}->( sprintf( "$id to $called did not pass regex check\n", _stringify($value) ) ); } } } { # if it UNIVERSAL::isa the string on the left then its the type on # the right my %isas = ( 'ARRAY' => ARRAYREF, 'HASH' => HASHREF, 'CODE' => CODEREF, 'GLOB' => GLOBREF, 'SCALAR' => SCALARREF, 'REGEXP' => SCALARREF, ); my %simple_refs = map { $_ => 1 } keys %isas; sub _get_type { return UNDEF unless defined $_[0]; my $ref = ref $_[0]; unless ($ref) { # catches things like: my $fh = do { local *FH; }; return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' ); return SCALAR; } return $isas{$ref} if $simple_refs{$ref}; foreach ( keys %isas ) { return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ ); } # I really hope this never happens. return UNKNOWN; } } { my %type_to_string = ( SCALAR() => 'scalar', ARRAYREF() => 'arrayref', HASHREF() => 'hashref', CODEREF() => 'coderef', GLOB() => 'glob', GLOBREF() => 'globref', SCALARREF() => 'scalarref', UNDEF() => 'undef', OBJECT() => 'object', UNKNOWN() => 'unknown', ); sub _typemask_to_strings { my $mask = shift; my @types; foreach ( SCALAR, ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF, SCALARREF, UNDEF, OBJECT, UNKNOWN ) { push @types, $type_to_string{$_} if $mask & $_; } return @types ? @types : ('unknown'); } } { my %defaults = ( ignore_case => 0, strip_leading => 0, allow_extra => 0, on_fail => sub { require Carp; Carp::croak( $_[0] ); }, stack_skip => 1, normalize_keys => undef, ); *set_options = \&validation_options; sub validation_options { my %opts = @_; my $caller = caller; foreach ( keys %defaults ) { $opts{$_} = $defaults{$_} unless exists $opts{$_}; } $Params::Validate::OPTIONS{$caller} = \%opts; } sub _get_options { my $caller = shift; if (@_) { return ( $Params::Validate::OPTIONS{$caller} ? { %{ $Params::Validate::OPTIONS{$caller} }, @_ } : { %defaults, @_ } ); } else { return ( exists $Params::Validate::OPTIONS{$caller} ? $Params::Validate::OPTIONS{$caller} : \%defaults ); } } } sub _get_called { my $extra_skip = $_[0] || 0; # always add one more for this sub $extra_skip++; my $called = ( exists $options->{called} ? $options->{called} : ( caller( $options->{stack_skip} + $extra_skip ) )[3] ); $called = '(unknown)' unless defined $called; return $called; } sub _stringify { return defined $_[0] ? qq{"$_[0]"} : 'undef'; } 1;