summaryrefslogtreecommitdiff
path: root/lib/Params/Validate/PP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Params/Validate/PP.pm')
-rw-r--r--lib/Params/Validate/PP.pm735
1 files changed, 735 insertions, 0 deletions
diff --git a/lib/Params/Validate/PP.pm b/lib/Params/Validate/PP.pm
new file mode 100644
index 0000000..e766475
--- /dev/null
+++ b/lib/Params/Validate/PP.pm
@@ -0,0 +1,735 @@
+package Params::Validate::PP;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.20';
+
+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 ) {
+ my $value = defined $p->{$key} ? qq|"$p->{$key}"| : 'undef';
+ _validate_one_param(
+ $p->{$key}, $p, $spec,
+ qq{The '$key' parameter (%s)}
+ );
+ }
+ }
+
+ if (@missing) {
+ my $called = _get_called();
+
+ my $missing = join ', ', map {"'$_'"} @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::confess( $_[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 = 'N/A' unless defined $called;
+
+ return $called;
+}
+
+sub _stringify {
+ return defined $_[0] ? qq{"$_[0]"} : 'undef';
+}
+
+1;
View Lorry Controller Status