diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Attribute/Params/Validate.pm | 208 | ||||
| -rw-r--r-- | lib/Params/Validate.pm | 900 | ||||
| -rw-r--r-- | lib/Params/Validate/Constants.pm | 39 | ||||
| -rw-r--r-- | lib/Params/Validate/PP.pm | 735 | ||||
| -rw-r--r-- | lib/Params/Validate/XS.pm | 51 | ||||
| -rw-r--r-- | lib/Params/Validate/XS.xs | 1811 | ||||
| -rw-r--r-- | lib/Params/ValidatePP.pm | 9 | ||||
| -rw-r--r-- | lib/Params/ValidateXS.pm | 9 |
8 files changed, 3762 insertions, 0 deletions
diff --git a/lib/Attribute/Params/Validate.pm b/lib/Attribute/Params/Validate.pm new file mode 100644 index 0000000..f72c16a --- /dev/null +++ b/lib/Attribute/Params/Validate.pm @@ -0,0 +1,208 @@ +package Attribute::Params::Validate; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use attributes; + +use Attribute::Handlers 0.79; + +# this will all be re-exported +use Params::Validate qw(:all); + +require Exporter; + +our @ISA = qw(Exporter); + +my %tags = ( + types => [ + qw( SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE UNDEF OBJECT ) + ], +); + +our %EXPORT_TAGS = ( + 'all' => [ qw( validation_options ), map { @{ $tags{$_} } } keys %tags ], + %tags, +); +our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'validation_options' ); + + +sub UNIVERSAL::Validate : ATTR(CODE, INIT) { + _wrap_sub( 'named', @_ ); +} + +sub UNIVERSAL::ValidatePos : ATTR(CODE, INIT) { + _wrap_sub( 'positional', @_ ); +} + +sub _wrap_sub { + my ( $type, $package, $symbol, $referent, $attr, $params ) = @_; + + my @p = ref $params ? @{$params} : $params; + + my $subname = $package . '::' . *{$symbol}{NAME}; + + my %attributes = map { $_ => 1 } attributes::get($referent); + my $is_method = $attributes{method}; + + { + no warnings 'redefine'; + no strict 'refs'; + + # An unholy mixture of closure and eval. This is done so that + # the code to automatically create the relevant scalars from + # the hash of params can create the scalars in the proper + # place lexically. + + my $code = <<"EOF"; +sub +{ + package $package; +EOF + + $code .= " my \$object = shift;\n" if $is_method; + + if ( $type eq 'named' ) { + $params = {@p}; + $code .= " Params::Validate::validate(\@_, \$params);\n"; + } + else { + $code .= " Params::Validate::validate_pos(\@_, \@p);\n"; + } + + $code .= " unshift \@_, \$object if \$object;\n" if $is_method; + + $code .= <<"EOF"; + \$referent->(\@_); +} +EOF + + my $sub = eval $code; + die $@ if $@; + + *{$subname} = $sub; + } +} + +1; + +# ABSTRACT: Define validation through subroutine attributes + +__END__ + +=pod + +=head1 NAME + +Attribute::Params::Validate - Define validation through subroutine attributes + +=head1 VERSION + +version 1.20 + +=head1 SYNOPSIS + + use Attribute::Params::Validate qw(:all); + + # takes named params (hash or hashref) + # foo is mandatory, bar is optional + sub foo : Validate( foo => 1, bar => 0 ) + { + # insert code here + } + + # takes positional params + # first two are mandatory, third is optional + sub bar : ValidatePos( 1, 1, 0 ) + { + # insert code here + } + + # for some reason Perl insists that the entire attribute be on one line + sub foo2 : Validate( foo => { type => ARRAYREF }, bar => { can => [ 'print', 'flush', 'frobnicate' ] }, baz => { type => SCALAR, callbacks => { 'numbers only' => sub { shift() =~ /^\d+$/ }, 'less than 90' => sub { shift() < 90 } } } ) + { + # insert code here + } + + # note that this is marked as a method. This is very important! + sub baz : Validate( foo => { type => ARRAYREF }, bar => { isa => 'Frobnicator' } ) method + { + # insert code here + } + +=head1 DESCRIPTION + +The Attribute::Params::Validate module allows you to validate method +or function call parameters just like Params::Validate does. However, +this module allows you to specify your validation spec as an +attribute, rather than by calling the C<validate> routine. + +Please see Params::Validate for more information on how you can +specify what validation is performed. + +=head2 EXPORT + +This module exports everything that Params::Validate does except for +the C<validate> and C<validate_pos> subroutines. + +=head2 ATTRIBUTES + +=over 4 + +=item * Validate + +This attribute corresponds to the C<validate> subroutine in +Params::Validate. + +=item * ValidatePos + +This attribute corresponds to the C<validate_pos> subroutine in +Params::Validate. + +=back + +=head2 OO + +If you are using this module to mark B<methods> for validation, as +opposed to subroutines, it is crucial that you mark these methods with +the C<:method> attribute, as well as the C<Validate> or C<ValidatePos> +attribute. + +If you do not do this, then the object or class used in the method +call will be passed to the validation routines, which is probably not +what you want. + +=head2 CAVEATS + +You B<must> put all the arguments to the C<Validate> or C<ValidatePos> +attribute on a single line, or Perl will complain. + +=head1 SEE ALSO + +Params::Validate + +=head1 AUTHORS + +=over 4 + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Ilya Martynov <ilya@martynov.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya Martynov. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut diff --git a/lib/Params/Validate.pm b/lib/Params/Validate.pm new file mode 100644 index 0000000..7a5ff01 --- /dev/null +++ b/lib/Params/Validate.pm @@ -0,0 +1,900 @@ +package Params::Validate; + +use 5.008001; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use Exporter; +use Module::Implementation; +use Params::Validate::Constants; + +use vars qw( $NO_VALIDATION %OPTIONS $options ); + +our @ISA = 'Exporter'; + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +our %EXPORT_TAGS = ( + 'all' => [ + qw( validate validate_pos validation_options validate_with ), + @types + ], + types => \@types, +); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'set_options' ); +our @EXPORT = qw( validate validate_pos ); + +$NO_VALIDATION = $ENV{PERL_NO_VALIDATION}; + +{ + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => [ + qw( + validate + validate_pos + validate_with + validation_options + set_options + ), + ], + ); + + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'PP' if $ENV{PV_TEST_PERL}; + + $loader->(); +} + +1; + +# ABSTRACT: Validate method/function parameters + +__END__ + +=pod + +=head1 NAME + +Params::Validate - Validate method/function parameters + +=head1 VERSION + +version 1.20 + +=head1 SYNOPSIS + + use Params::Validate qw(:all); + + # takes named params (hash or hashref) + sub foo { + validate( + @_, { + foo => 1, # mandatory + bar => 0, # optional + } + ); + } + + # takes positional params + sub bar { + # first two are mandatory, third is optional + validate_pos( @_, 1, 1, 0 ); + } + + sub foo2 { + validate( + @_, { + foo => + # specify a type + { type => ARRAYREF }, + bar => + # specify an interface + { can => [ 'print', 'flush', 'frobnicate' ] }, + baz => { + type => SCALAR, # a scalar ... + # ... that is a plain integer ... + regex => qr/^\d+$/, + callbacks => { # ... and smaller than 90 + 'less than 90' => sub { shift() < 90 }, + }, + } + } + ); + } + + sub callback_with_custom_error { + validate( + @_, + { + foo => callbacks => { + 'is an integer' => sub { + return 1 if $_[0] =~ /^-?[1-9][0-9]*$/; + die "$_[0] is not a valid integer value"; + }, + } + } + ); + } + + sub with_defaults { + my %p = validate( + @_, { + # required + foo => 1, + # $p{bar} will be 99 if bar is not given. bar is now + # optional. + bar => { default => 99 } + } + ); + } + + sub pos_with_defaults { + my @p = validate_pos( @_, 1, { default => 99 } ); + } + + sub sets_options_on_call { + my %p = validate_with( + params => \@_, + spec => { foo => { type => SCALAR, default => 2 } }, + normalize_keys => sub { $_[0] =~ s/^-//; lc $_[0] }, + ); + } + +=head1 DESCRIPTION + +The Params::Validate module allows you to validate method or function +call parameters to an arbitrary level of specificity. At the simplest +level, it is capable of validating the required parameters were given +and that no unspecified additional parameters were passed in. + +It is also capable of determining that a parameter is of a specific +type, that it is an object of a certain class hierarchy, that it +possesses certain methods, or applying validation callbacks to +arguments. + +=head2 EXPORT + +The module always exports the C<validate()> and C<validate_pos()> +functions. + +It also has an additional function available for export, +C<validate_with>, which can be used to validate any type of +parameters, and set various options on a per-invocation basis. + +In addition, it can export the following constants, which are used as +part of the type checking. These are C<SCALAR>, C<ARRAYREF>, +C<HASHREF>, C<CODEREF>, C<GLOB>, C<GLOBREF>, and C<SCALARREF>, +C<UNDEF>, C<OBJECT>, C<BOOLEAN>, and C<HANDLE>. These are explained +in the section on L<Type Validation|Params::Validate/Type Validation>. + +The constants are available via the export tag C<:types>. There is +also an C<:all> tag which includes all of the constants as well as the +C<validation_options()> function. + +=encoding UTF-8 + +=head1 PARAMETER VALIDATION + +The validation mechanisms provided by this module can handle both +named or positional parameters. For the most part, the same features +are available for each. The biggest difference is the way that the +validation specification is given to the relevant subroutine. The +other difference is in the error messages produced when validation +checks fail. + +When handling named parameters, the module will accept either a hash +or a hash reference. + +Subroutines expecting named parameters should call the C<validate()> +subroutine like this: + + validate( + @_, { + parameter1 => validation spec, + parameter2 => validation spec, + ... + } + ); + +Subroutines expecting positional parameters should call the +C<validate_pos()> subroutine like this: + + validate_pos( @_, { validation spec }, { validation spec } ); + +=head2 Mandatory/Optional Parameters + +If you just want to specify that some parameters are mandatory and +others are optional, this can be done very simply. + +For a subroutine expecting named parameters, you would do this: + + validate( @_, { foo => 1, bar => 1, baz => 0 } ); + +This says that the "foo" and "bar" parameters are mandatory and that +the "baz" parameter is optional. The presence of any other +parameters will cause an error. + +For a subroutine expecting positional parameters, you would do this: + + validate_pos( @_, 1, 1, 0, 0 ); + +This says that you expect at least 2 and no more than 4 parameters. +If you have a subroutine that has a minimum number of parameters but +can take any maximum number, you can do this: + + validate_pos( @_, 1, 1, (0) x (@_ - 2) ); + +This will always be valid as long as at least two parameters are +given. A similar construct could be used for the more complex +validation parameters described further on. + +Please note that this: + + validate_pos( @_, 1, 1, 0, 1, 1 ); + +makes absolutely no sense, so don't do it. Any zeros must come at the +end of the validation specification. + +In addition, if you specify that a parameter can have a default, then +it is considered optional. + +=head2 Type Validation + +This module supports the following simple types, which can be +L<exported as constants|/EXPORT>: + +=over 4 + +=item * SCALAR + +A scalar which is not a reference, such as C<10> or C<'hello'>. A +parameter that is undefined is B<not> treated as a scalar. If you +want to allow undefined values, you will have to specify C<SCALAR | +UNDEF>. + +=item * ARRAYREF + +An array reference such as C<[1, 2, 3]> or C<\@foo>. + +=item * HASHREF + +A hash reference such as C<< { a => 1, b => 2 } >> or C<\%bar>. + +=item * CODEREF + +A subroutine reference such as C<\&foo_sub> or C<sub { print "hello" }>. + +=item * GLOB + +This one is a bit tricky. A glob would be something like C<*FOO>, but +not C<\*FOO>, which is a glob reference. It should be noted that this +trick: + + my $fh = do { local *FH; }; + +makes C<$fh> a glob, not a glob reference. On the other hand, the +return value from C<Symbol::gensym> is a glob reference. Either can +be used as a file or directory handle. + +=item * GLOBREF + +A glob reference such as C<\*FOO>. See the L<GLOB|GLOB> entry above +for more details. + +=item * SCALARREF + +A reference to a scalar such as C<\$x>. + +=item * UNDEF + +An undefined value + +=item * OBJECT + +A blessed reference. + +=item * BOOLEAN + +This is a special option, and is just a shortcut for C<UNDEF | SCALAR>. + +=item * HANDLE + +This option is also special, and is just a shortcut for C<GLOB | +GLOBREF>. However, it seems likely that most people interested in +either globs or glob references are likely to really be interested in +whether the parameter in question could be a valid file or directory +handle. + +=back + +To specify that a parameter must be of a given type when using named +parameters, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HASHREF } + } + ); + +If a parameter can be of more than one type, just use the bitwise or +(C<|>) operator to combine them. + + validate( @_, { foo => { type => GLOB | GLOBREF } ); + +For positional parameters, this can be specified as follows: + + validate_pos( @_, { type => SCALAR | ARRAYREF }, { type => CODEREF } ); + +=head2 Interface Validation + +To specify that a parameter is expected to have a certain set of +methods, we can do the following: + + validate( + @_, { + foo => + # just has to be able to ->bar + { can => 'bar' } + } + ); + + ... or ... + + validate( + @_, { + foo => + # must be able to ->bar and ->print + { can => [qw( bar print )] } + } + ); + +=head2 Class Validation + +A word of warning. When constructing your external interfaces, it is +probably better to specify what methods you expect an object to +have rather than what class it should be of (or a child of). This +will make your API much more flexible. + +With that said, if you want to validate that an incoming parameter +belongs to a class (or child class) or classes, do: + + validate( + @_, + { foo => { isa => 'My::Frobnicator' } } + ); + + ... or ... + + validate( + @_, + # must be both, not either! + { foo => { isa => [qw( My::Frobnicator IO::Handle )] } } + ); + +=head2 Regex Validation + +If you want to specify that a given parameter must match a specific +regular expression, this can be done with "regex" spec key. For +example: + + validate( + @_, + { foo => { regex => qr/^\d+$/ } } + ); + +The value of the "regex" key may be either a string or a pre-compiled +regex created via C<qr>. + +If the value being checked against a regex is undefined, the regex is +explicitly checked against the empty string ('') instead, in order to +avoid "Use of uninitialized value" warnings. + +The C<Regexp::Common> module on CPAN is an excellent source of regular +expressions suitable for validating input. + +=head2 Callback Validation + +If none of the above are enough, it is possible to pass in one or more +callbacks to validate the parameter. The callback will be given the +B<value> of the parameter as its first argument. Its second argument +will be all the parameters, as a reference to either a hash or array. +Callbacks are specified as hash reference. The key is an id for the +callback (used in error messages) and the value is a subroutine +reference, such as: + + validate( + @_, + { + foo => { + callbacks => { + 'smaller than a breadbox' => sub { shift() < $breadbox }, + 'green or blue' => sub { + return 1 if $_[0] eq 'green' || $_[0] eq 'blue'; + die "$_[0] is not green or blue!"; + } + } + } + } + ); + + validate( + @_, { + foo => { + callbacks => { + 'bigger than baz' => sub { $_[0] > $_[1]->{baz} } + } + } + } + ); + +The callback should return a true value if the value is valid. If not, it can +return false or die. If you return false, a generic error message will be +thrown by C<Params::Validate>. + +If your callback dies instead you can provide a custom error message. If the +callback dies with a plain string, this string will be appended to an +exception message generated by C<Params::Validate>. If the callback dies with +a reference (blessed or not), then this will be rethrown as-is by +C<Params::Validate>. + +=head2 Untainting + +If you want values untainted, set the "untaint" key in a spec hashref +to a true value, like this: + + my %p = validate( + @_, { + foo => { type => SCALAR, untaint => 1 }, + bar => { type => ARRAYREF } + } + ); + +This will untaint the "foo" parameter if the parameters are valid. + +Note that untainting is only done if I<all parameters> are valid. +Also, only the return values are untainted, not the original values +passed into the validation function. + +Asking for untainting of a reference value will not do anything, as +C<Params::Validate> will only attempt to untaint the reference itself. + +=head2 Mandatory/Optional Revisited + +If you want to specify something such as type or interface, plus the +fact that a parameter can be optional, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => ARRAYREF, optional => 1 } + } + ); + +or this for positional parameters: + + validate_pos( + @_, + { type => SCALAR }, + { type => ARRAYREF, optional => 1 } + ); + +By default, parameters are assumed to be mandatory unless specified as +optional. + +=head2 Dependencies + +It also possible to specify that a given optional parameter depends on +the presence of one or more other optional parameters. + + validate( + @_, { + cc_number => { + type => SCALAR, + optional => 1, + depends => [ 'cc_expiration', 'cc_holder_name' ], + }, + cc_expiration => { type => SCALAR, optional => 1 }, + cc_holder_name => { type => SCALAR, optional => 1 }, + } + ); + +In this case, "cc_number", "cc_expiration", and "cc_holder_name" are +all optional. However, if "cc_number" is provided, then +"cc_expiration" and "cc_holder_name" must be provided as well. + +This allows you to group together sets of parameters that all must be +provided together. + +The C<validate_pos()> version of dependencies is slightly different, +in that you can only depend on one other parameter. Also, if for +example, the second parameter 2 depends on the fourth parameter, then +it implies a dependency on the third parameter as well. This is +because if the fourth parameter is required, then the user must also +provide a third parameter so that there can be four parameters in +total. + +C<Params::Validate> will die if you try to depend on a parameter not +declared as part of your parameter specification. + +=head2 Specifying defaults + +If the C<validate()> or C<validate_pos()> functions are called in a list +context, they will return a hash or containing the original parameters plus +defaults as indicated by the validation spec. + +If the function is not called in a list context, providing a default +in the validation spec still indicates that the parameter is optional. + +The hash or array returned from the function will always be a copy of +the original parameters, in order to leave C<@_> untouched for the +calling function. + +Simple examples of defaults would be: + + my %p = validate( @_, { foo => 1, bar => { default => 99 } } ); + + my @p = validate_pos( @_, 1, { default => 99 } ); + +In scalar context, a hash reference or array reference will be +returned, as appropriate. + +=head1 USAGE NOTES + +=head2 Validation failure + +By default, when validation fails C<Params::Validate> calls +C<Carp::confess()>. This can be overridden by setting the C<on_fail> +option, which is described in the L<"GLOBAL" OPTIONS|"GLOBAL" OPTIONS> +section. + +=head2 Method calls + +When using this module to validate the parameters passed to a method +call, you will probably want to remove the class/object from the +parameter list B<before> calling C<validate()> or C<validate_pos()>. +If your method expects named parameters, then this is necessary for +the C<validate()> function to actually work, otherwise C<@_> will not +be usable as a hash, because it will first have your object (or +class) B<followed> by a set of keys and values. + +Thus the idiomatic usage of C<validate()> in a method call will look +something like this: + + sub method { + my $self = shift; + + my %params = validate( + @_, { + foo => 1, + bar => { type => ARRAYREF }, + } + ); + } + +=head2 Speeding Up Validation + +In most cases, the validation spec will remain the same for each call to a +subroutine. In that case, you can speed up validation by defining the +validation spec just once, rather than on each call to the subroutine: + + my %spec = ( ... ); + sub foo { + my %params = validate( @_, \%spec ); + } + +You can also use the C<state> feature to do this: + + use feature 'state'; + + sub foo { + state $spec = { ... }; + my %params = validate( @_, $spec ); + } + +=head1 "GLOBAL" OPTIONS + +Because the API for the C<validate()> and C<validate_pos()> functions does not +make it possible to specify any options other than the validation spec, it is +possible to set some options as pseudo-'globals'. These allow you to specify +such things as whether or not the validation of named parameters should be +case sensitive, for one example. + +These options are called pseudo-'globals' because these settings are +B<only applied to calls originating from the package that set the +options>. + +In other words, if I am in package C<Foo> and I call +C<validation_options()>, those options are only in effect when I call +C<validate()> from package C<Foo>. + +While this is quite different from how most other modules operate, I +feel that this is necessary in able to make it possible for one +module/application to use Params::Validate while still using other +modules that also use Params::Validate, perhaps with different +options set. + +The downside to this is that if you are writing an app with a standard +calling style for all functions, and your app has ten modules, B<each +module must include a call to C<validation_options()>>. You could of +course write a module that all your modules use which uses various +trickery to do this when imported. + +=head2 Options + +=over 4 + +=item * normalize_keys => $callback + +This option is only relevant when dealing with named parameters. + +This callback will be used to transform the hash keys of both the +parameters and the parameter spec when C<validate()> or +C<validate_with()> are called. + +Any alterations made by this callback will be reflected in the +parameter hash that is returned by the validation function. For +example: + + sub foo { + return validate_with( + params => \@_, + spec => { foo => { type => SCALAR } }, + normalize_keys => + sub { my $k = shift; $k =~ s/^-//; return uc $k }, + ); + + } + + %p = foo( foo => 20 ); + + # $p{FOO} is now 20 + + %p = foo( -fOo => 50 ); + + # $p{FOO} is now 50 + +The callback must return a defined value. + +If a callback is given then the deprecated "ignore_case" and +"strip_leading" options are ignored. + +=item * allow_extra => $boolean + +If true, then the validation routine will allow extra parameters not +named in the validation specification. In the case of positional +parameters, this allows an unlimited number of maximum parameters +(though a minimum may still be set). Defaults to false. + +=item * on_fail => $callback + +If given, this callback will be called whenever a validation check +fails. It will be called with a single parameter, which will be a +string describing the failure. This is useful if you wish to have +this module throw exceptions as objects rather than as strings, for +example. + +This callback is expected to C<die()> internally. If it does not, the +validation will proceed onwards, with unpredictable results. + +The default is to simply use the Carp module's C<confess()> function. + +=item * stack_skip => $number + +This tells Params::Validate how many stack frames to skip when finding +a subroutine name to use in error messages. By default, it looks one +frame back, at the immediate caller to C<validate()> or +C<validate_pos()>. If this option is set, then the given number of +frames are skipped instead. + +=item * ignore_case => $boolean + +DEPRECATED + +This is only relevant when dealing with named parameters. If it is +true, then the validation code will ignore the case of parameter +names. Defaults to false. + +=item * strip_leading => $characters + +DEPRECATED + +This too is only relevant when dealing with named parameters. If this +is given then any parameters starting with these characters will be +considered equivalent to parameters without them entirely. For +example, if this is specified as '-', then C<-foo> and C<foo> would be +considered identical. + +=back + +=head1 PER-INVOCATION OPTIONS + +The C<validate_with()> function can be used to set the options listed +above on a per-invocation basis. For example: + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + ); + +In addition to the options listed above, it is also possible to set +the option "called", which should be a string. This string will be +used in any error messages caused by a failure to meet the validation +spec. + +This subroutine will validate named parameters as a hash if the "spec" +parameter is a hash reference. If it is an array reference, the +parameters are assumed to be positional. + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + + my @p = validate_with( + params => \@_, + spec => [ + { type => SCALAR }, + { default => 10 } + ], + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + +=head1 DISABLING VALIDATION + +If the environment variable C<PERL_NO_VALIDATION> is set to something +true, then validation is turned off. This may be useful if you only +want to use this module during development but don't want the speed +hit during production. + +The only error that will be caught will be when an odd number of +parameters are passed into a function/method that expects a hash. + +If you want to selectively turn validation on and off at runtime, you +can directly set the C<$Params::Validate::NO_VALIDATION> global +variable. It is B<strongly> recommended that you B<localize> any +changes to this variable, because other modules you are using may +expect validation to be on when they execute. For example: + + { + local $Params::Validate::NO_VALIDATION = 1; + + # no error + foo( bar => 2 ); + } + + # error + foo( bar => 2 ); + + sub foo { + my %p = validate( @_, { foo => 1 } ); + ...; + } + +But if you want to shoot yourself in the foot and just turn it off, go +ahead! + +=head1 TAINT MODE + +The XS implementation of this module has some problems Under taint mode with +version of Perl before 5.14. If validation I<fails>, then instead of getting +the expected error message you'll get a message like "Insecure dependency in +eval_sv". This can be worked around by either untainting the arguments +yourself, using the pure Perl implementation, or upgrading your Perl. + +=head1 LIMITATIONS + +Right now there is no way (short of a callback) to specify that +something must be of one of a list of classes, or that it must possess +one of a list of methods. If this is desired, it can be added in the +future. + +Ideally, there would be only one validation function. If someone +figures out how to do this, please let me know. + +=head1 SUPPORT + +Please submit bugs and patches to the CPAN RT system at +http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params%3A%3AValidate or +via email at bug-params-validate@rt.cpan.org. + +Support questions can be sent to Dave at autarch@urth.org. + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, +please consider making a "donation" to me via PayPal. I spend a lot of +free time creating free software, and would appreciate any support +you'd care to offer. + +Please note that B<I am not suggesting that you must do this> in order +for me to continue working on this particular software. I will +continue to do so, inasmuch as I have in the past, for as long as it +interests me. + +Similarly, a donation made in this way will probably not make me work +on this software much more, unless I get so many donations that I can +consider working on free software full time, which seems unlikely at +best. + +To donate, log into PayPal and send money to autarch@urth.org or use +the button on this page: +L<http://www.urth.org/~autarch/fs-donation.html> + +=head1 AUTHORS + +=over 4 + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Ilya Martynov <ilya@martynov.org> + +=back + +=head1 CONTRIBUTORS + +=for stopwords Ivan Bessarabov J.R. Mash Noel Maddy Olivier Mengué Vincent Pit + +=over 4 + +=item * + +Ivan Bessarabov <ivan@bessarabov.ru> + +=item * + +J.R. Mash <jmash.code@gmail.com> + +=item * + +Noel Maddy <zhtwnpanta@gmail.com> + +=item * + +Olivier Mengué <dolmen@cpan.org> + +=item * + +Vincent Pit <perl@profvince.com> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya Martynov. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut diff --git a/lib/Params/Validate/Constants.pm b/lib/Params/Validate/Constants.pm new file mode 100644 index 0000000..6204282 --- /dev/null +++ b/lib/Params/Validate/Constants.pm @@ -0,0 +1,39 @@ +package Params::Validate::Constants; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +our @ISA = 'Exporter'; + +our @EXPORT = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT + UNKNOWN +); + +sub SCALAR () { 1 } +sub ARRAYREF () { 2 } +sub HASHREF () { 4 } +sub CODEREF () { 8 } +sub GLOB () { 16 } +sub GLOBREF () { 32 } +sub SCALARREF () { 64 } +sub UNKNOWN () { 128 } +sub UNDEF () { 256 } +sub OBJECT () { 512 } + +sub HANDLE () { 16 | 32 } +sub BOOLEAN () { 1 | 256 } + +1; 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; diff --git a/lib/Params/Validate/XS.pm b/lib/Params/Validate/XS.pm new file mode 100644 index 0000000..256131d --- /dev/null +++ b/lib/Params/Validate/XS.pm @@ -0,0 +1,51 @@ +package Params::Validate::XS; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use Carp; + +my $default_fail = sub { + Carp::confess( $_[0] ); +}; + +{ + my %defaults = ( + ignore_case => 0, + strip_leading => 0, + allow_extra => 0, + on_fail => $default_fail, + 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; + } + + use XSLoader; + XSLoader::load( + __PACKAGE__, + exists $Params::Validate::XS::{VERSION} + ? ${ $Params::Validate::XS::{VERSION} } + : (), + ); +} + +sub _check_regex_from_xs { + return ( defined $_[0] ? $_[0] : '' ) =~ /$_[1]/ ? 1 : 0; +} + +1; diff --git a/lib/Params/Validate/XS.xs b/lib/Params/Validate/XS.xs new file mode 100644 index 0000000..109145a --- /dev/null +++ b/lib/Params/Validate/XS.xs @@ -0,0 +1,1811 @@ +/* Copyright (c) 2000-2012 Dave Rolsky and Ilya Martynov */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +#if (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) +#define INLINE inline +#else +#define INLINE +#endif + +/* type constants */ +#define SCALAR 1 +#define ARRAYREF 2 +#define HASHREF 4 +#define CODEREF 8 +#define GLOB 16 +#define GLOBREF 32 +#define SCALARREF 64 +#define UNKNOWN 128 +#define UNDEF 256 +#define OBJECT 512 + +#define HANDLE (GLOB | GLOBREF) +#define BOOLEAN (SCALAR | UNDEF) + +/* return data macros */ +#define RETURN_ARRAY(ret) \ + STMT_START \ + { \ + I32 i; \ + switch(GIMME_V) \ + { \ + case G_VOID: \ + return; \ + case G_ARRAY: \ + EXTEND(SP, av_len(ret) + 1); \ + for(i = 0; i <= av_len(ret); i++) \ + { \ + PUSHs(*av_fetch(ret, i, 1)); \ + } \ + break; \ + case G_SCALAR: \ + XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \ + break; \ + } \ + } STMT_END \ + +#define RETURN_HASH(ret) \ + STMT_START \ + { \ + HE* he; \ + I32 keys; \ + switch(GIMME_V) \ + { \ + case G_VOID: \ + return; \ + case G_ARRAY: \ + keys = hv_iterinit(ret); \ + EXTEND(SP, keys * 2); \ + while ((he = hv_iternext(ret))) \ + { \ + PUSHs(HeSVKEY_force(he)); \ + PUSHs(HeVAL(he)); \ + } \ + break; \ + case G_SCALAR: \ + XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \ + break; \ + } \ + } STMT_END + + +static SV *module; +void peek(SV *thing) +{ + if (NULL == module) { + module = newSVpv("Devel::Peek", 0); + load_module(PERL_LOADMOD_NOIMPORT, module, NULL); + } + + { + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(thing); + PUTBACK; + + (void)call_pv("Devel::Peek::Dump", G_VOID); + + SPAGAIN; + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +INLINE static bool +no_validation() { + SV* no_v; + + no_v = get_sv("Params::Validate::NO_VALIDATION", 0); + if (! no_v) + croak("Cannot retrieve $Params::Validate::NO_VALIDATION\n"); + + return SvTRUE(no_v); +} + +/* return type string that corresponds to typemask */ +INLINE static SV* +typemask_to_string(IV mask) { + SV* buffer; + IV empty = 1; + + buffer = sv_2mortal(newSVpv("", 0)); + + if (mask & SCALAR) { + sv_catpv(buffer, "scalar"); + empty = 0; + } + if (mask & ARRAYREF) { + sv_catpv(buffer, empty ? "arrayref" : " arrayref"); + empty = 0; + } + if (mask & HASHREF) { + sv_catpv(buffer, empty ? "hashref" : " hashref"); + empty = 0; + } + if (mask & CODEREF) { + sv_catpv(buffer, empty ? "coderef" : " coderef"); + empty = 0; + } + if (mask & GLOB) { + sv_catpv(buffer, empty ? "glob" : " glob"); + empty = 0; + } + if (mask & GLOBREF) { + sv_catpv(buffer, empty ? "globref" : " globref"); + empty = 0; + } + if (mask & SCALARREF) { + sv_catpv(buffer, empty ? "scalarref" : " scalarref"); + empty = 0; + } + if (mask & UNDEF) { + sv_catpv(buffer, empty ? "undef" : " undef"); + empty = 0; + } + if (mask & OBJECT) { + sv_catpv(buffer, empty ? "object" : " object"); + empty = 0; + } + if (mask & UNKNOWN) { + sv_catpv(buffer, empty ? "unknown" : " unknown"); + empty = 0; + } + + return buffer; +} + +/* compute numberic datatype for variable */ +INLINE static IV +get_type(SV* sv) { + IV type = 0; + + if (SvTYPE(sv) == SVt_PVGV) { + return GLOB; + } + if (!SvOK(sv)) { + return UNDEF; + } + if (!SvROK(sv)) { + return SCALAR; + } + + switch (SvTYPE(SvRV(sv))) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_PV: + #if PERL_VERSION <= 10 + case SVt_RV: + #endif + case SVt_PVMG: + case SVt_PVIV: + case SVt_PVNV: + #if PERL_VERSION <= 8 + case SVt_PVBM: + #elif PERL_VERSION >= 11 + case SVt_REGEXP: + #endif + type = SCALARREF; + break; + case SVt_PVAV: + type = ARRAYREF; + break; + case SVt_PVHV: + type = HASHREF; + break; + case SVt_PVCV: + type = CODEREF; + break; + case SVt_PVGV: + type = GLOBREF; + break; + /* Perl 5.10 has a bunch of new types that I don't think will ever + actually show up here (I hope), but not handling them makes the + C compiler cranky. */ + default: + type = UNKNOWN; + break; + } + + if (type) { + if (sv_isobject(sv)) return type | OBJECT; + return type; + } + + /* Getting here should not be possible */ + return UNKNOWN; +} + +/* get an article for given string */ +INLINE static const char* +article(SV* string) { + STRLEN len; + char* rawstr; + + rawstr = SvPV(string, len); + if (len) { + switch(rawstr[0]) { + case 'a': + case 'e': + case 'i': + case 'o': + case 'u': + return "an"; + } + } + + return "a"; +} + +char * +string_representation(SV* value) { + if(SvOK(value)) { + return (void *)form("\"%s\"", SvPV_nolen(value)); + } + else { + return (void *)"undef"; + } +} + +/* raises exception either using user-defined callback or using + built-in method */ +static void +validation_failure(SV* message, HV* options) { + SV** temp; + SV* on_fail; + + if ((temp = hv_fetch(options, "on_fail", 7, 0))) { + SvGETMAGIC(*temp); + on_fail = *temp; + } + else { + on_fail = NULL; + } + + { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + mXPUSHs(message); + PUTBACK; + + /* use user defined callback if available */ + if (on_fail) { + call_sv(on_fail, G_DISCARD); + } + else { + /* by default resort to Carp::confess for error reporting */ + call_pv("Carp::confess", G_DISCARD); + } + + /* We shouldn't get here if the thing we just called dies, but it + doesn't hurt to be careful. */ + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + } + + return; +} + +/* get called subroutine fully qualified name */ +static SV* +get_caller(HV* options) { + SV** temp; + + if ((temp = hv_fetch(options, "called", 6, 0))) { + SvGETMAGIC(*temp); + SvREFCNT_inc(*temp); + return *temp; + } + else { + IV frame; + SV *caller; +#if PERL_VERSION >= 14 + const PERL_CONTEXT *cx; + GV *cvgv; +# else + SV *buffer; +#endif + + if ((temp = hv_fetch(options, "stack_skip", 10, 0))) { + SvGETMAGIC(*temp); + frame = SvIV(*temp); + } + else { + frame = 1; + } + +#if PERL_VERSION >= 14 + if (frame > 0) { + frame--; + } + + cx = caller_cx(frame, NULL); + + if (cx) { + switch (CxTYPE(cx)) { + case CXt_EVAL: + caller = newSVpv("\"eval\"", 6); + break; + case CXt_SUB: + cvgv = CvGV(cx->blk_sub.cv); + caller = newSV(0); + if (cvgv && isGV(cvgv)) { + gv_efullname4(caller, cvgv, NULL, 1); + } + break; + default: + caller = newSVpv("(unknown)", 9); + break; + } + } + else { + caller = newSVpv("(unknown)", 9); + } +#else + buffer = sv_2mortal(newSVpvf("(caller(%d))[3]", (int) frame)); + + caller = eval_pv(SvPV_nolen(buffer), 1); + if (SvTYPE(caller) == SVt_NULL) { + sv_setpv(caller, "(unknown"); + } + + /* This will be decremented by the code that asked for this value, but + we need to do this here because the return value of caller() is + mortal and has a refcnt of 1. */ + SvREFCNT_inc(caller); +#endif + + return caller; + } +} + +/* $value->isa alike validation */ +static IV +validate_isa(SV* value, SV* package, char* id, HV* options) { + IV ok = 1; + + if (! value) { + return 0; + } + + SvGETMAGIC(value); + if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) { + dSP; + + SV* ret; + IV count; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(package); + PUTBACK; + + count = call_method("isa", G_SCALAR); + + if (! count) + croak("Calling isa did not return a value"); + + SPAGAIN; + + ret = POPs; + SvGETMAGIC(ret); + + ok = SvTRUE(ret); + + PUTBACK; + FREETMPS; + LEAVE; + } + else { + ok = 0; + } + + if (! ok) { + SV *caller = get_caller(options); + SV* buffer = newSVpvf(id, string_representation(value)); + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " was not "); + sv_catpv(buffer, article(package)); + sv_catpv(buffer, " '"); + sv_catsv(buffer, package); + sv_catpv(buffer, "' (it is "); + if ( SvOK(value) ) { + sv_catpv(buffer, article(value)); + sv_catpv(buffer, " "); + sv_catsv(buffer, value); + } + else { + sv_catpv(buffer, "undef"); + } + sv_catpv(buffer, ")\n"); + validation_failure(buffer, options); + } + + return 1; +} + +static IV +validate_can(SV* value, SV* method, char* id, HV* options) { + IV ok = 1; + + if (! value) { + return 0; + } + + SvGETMAGIC(value); + if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) { + dSP; + + SV* ret; + IV count; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(method); + PUTBACK; + + count = call_method("can", G_SCALAR); + + if (! count) + croak("Calling can did not return a value"); + + SPAGAIN; + + ret = POPs; + SvGETMAGIC(ret); + + ok = SvTRUE(ret); + + PUTBACK; + FREETMPS; + LEAVE; + } + else { + ok = 0; + } + + if (! ok) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " does not have the method: '"); + sv_catsv(buffer, method); + sv_catpv(buffer, "'\n"); + validation_failure(buffer, options); + } + + return 1; +} + +/* validates specific parameter using supplied parameter specification */ +static IV +validate_one_param(SV* value, SV* params, HV* spec, char* id, HV* options, IV* untaint) { + SV** temp; + IV i; + + /* + HE* he; + hv_iterinit(spec); + + while (he = hv_iternext(spec)) { + STRLEN len; + char* key = HePV(he, len); + int ok = 0; + int j; + for ( j = 0; j < VALID_KEY_COUNT; j++ ) { + if ( strcmp( key, valid_keys[j] ) == 0) { + ok = 1; + break; + } + } + + if ( ! ok ) { + SV* buffer = sv_2mortal(newSVpv("\"",0)); + sv_catpv( buffer, key ); + sv_catpv( buffer, "\" is not an allowed validation spec key\n"); + validation_failure(buffer, options); + } + } + */ + + /* check type */ + if ((temp = hv_fetch(spec, "type", 4, 0))) { + IV type; + + if ( ! ( SvOK(*temp) + && looks_like_number(*temp) + && SvIV(*temp) > 0 ) ) { + + SV* buffer = newSVpvf(id, string_representation(value)); + sv_catpv( buffer, " has a type specification which is not a number. It is "); + if ( SvOK(*temp) ) { + sv_catpv( buffer, "a string - " ); + sv_catsv( buffer, *temp ); + } + else { + sv_catpv( buffer, "undef"); + } + sv_catpv( buffer, ".\n Use the constants exported by Params::Validate to declare types." ); + + validation_failure(buffer, options); + } + + SvGETMAGIC(*temp); + type = get_type(value); + if (! (type & SvIV(*temp))) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + SV* is; + SV* allowed; + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " was "); + is = typemask_to_string(type); + allowed = typemask_to_string(SvIV(*temp)); + sv_catpv(buffer, article(is)); + sv_catpv(buffer, " '"); + sv_catsv(buffer, is); + sv_catpv(buffer, "', which is not one of the allowed types: "); + sv_catsv(buffer, allowed); + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + } + + /* check isa */ + if ((temp = hv_fetch(spec, "isa", 3, 0))) { + SvGETMAGIC(*temp); + + if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) { + AV* array = (AV*) SvRV(*temp); + + for(i = 0; i <= av_len(array); i++) { + SV* package; + + package = *av_fetch(array, i, 1); + if (! package) { + return 0; + } + + SvGETMAGIC(package); + if (! validate_isa(value, package, id, options)) { + return 0; + } + } + } + else { + if (! validate_isa(value, *temp, id, options)) { + return 0; + } + } + } + + /* check can */ + if ((temp = hv_fetch(spec, "can", 3, 0))) { + SvGETMAGIC(*temp); + if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) { + AV* array = (AV*) SvRV(*temp); + + for (i = 0; i <= av_len(array); i++) { + SV* method; + + method = *av_fetch(array, i, 1); + if (! method) { + return 0; + } + + SvGETMAGIC(method); + + if (! validate_can(value, method, id, options)) { + return 0; + } + } + } + else { + if (! validate_can(value, *temp, id, options)) { + return 0; + } + } + } + + /* let callbacks to do their tests */ + if ((temp = hv_fetch(spec, "callbacks", 9, 0))) { + HE* he; + + SvGETMAGIC(*temp); + if (!(SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVHV)) { + SV* buffer = newSVpv("'callbacks' validation parameter for '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " must be a hash reference\n"); + validation_failure(buffer, options); + } + + hv_iterinit((HV*) SvRV(*temp)); + while ((he = hv_iternext((HV*) SvRV(*temp)))) { + SV* ret; + IV ok; + IV count; + SV *err; + + if (!(SvROK(HeVAL(he)) && SvTYPE(SvRV(HeVAL(he))) == SVt_PVCV)) { + SV* buffer = newSVpv("callback '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, HeSVKEY_force(he)); + sv_catpv(buffer, "' for "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " is not a subroutine reference\n"); + validation_failure(buffer, options); + } + + { + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + mPUSHs(newRV_inc(params)); + PUTBACK; + + /* local $@ = q{}; */ + save_scalar(PL_errgv); + sv_setpv(ERRSV, ""); + + count = call_sv(SvRV(HeVAL(he)), G_EVAL|G_SCALAR); + + SPAGAIN; + + if (!count) { + croak("Validation callback did not return anything"); + } + + ret = POPs; + SvGETMAGIC(ret); + ok = SvTRUE(ret); + + err = newSV(0); + SvSetSV_nosteal(err, ERRSV); + + PUTBACK; + FREETMPS; + LEAVE; + + if (! ok) { + if (SvROK(err)) { + validation_failure(err, options); + } + else { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " did not pass the '"); + sv_catsv(buffer, HeSVKEY_force(he)); + sv_catpv(buffer, "' callback"); + if (SvLEN(err) > 0) { + sv_catpv(buffer, ": "); + sv_catsv(buffer, err); + } + sv_catpv(buffer, "\n"); + validation_failure(buffer, options); + } + } + else { + SvREFCNT_dec(err); + } + } + } + } + + if ((temp = hv_fetch(spec, "regex", 5, 0))) { + dSP; + + IV has_regex = 0; + IV ok; + + SvGETMAGIC(*temp); + if (SvPOK(*temp)) { + has_regex = 1; + } + else if (SvROK(*temp)) { + SV* svp; + + svp = (SV*)SvRV(*temp); + + #if PERL_VERSION <= 10 + if (SvMAGICAL(svp) && mg_find(svp, PERL_MAGIC_qr)) { + has_regex = 1; + } + #else + if (SvTYPE(svp) == SVt_REGEXP) { + has_regex = 1; + } + #endif + } + + if (!has_regex) { + SV* buffer = newSVpv("'regex' validation parameter for '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " must be a string or qr// regex\n"); + validation_failure(buffer, options); + } + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(*temp); + PUTBACK; + call_pv("Params::Validate::XS::_check_regex_from_xs", G_SCALAR); + SPAGAIN; + ok = POPi; + PUTBACK; + + if (!ok) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " did not pass regex check\n"); + validation_failure(buffer, options); + } + } + + if ((temp = hv_fetch(spec, "untaint", 7, 0))) { + if (SvTRUE(*temp)) { + *untaint = 1; + } + } + + return 1; +} + +/* merges one hash into another (not deep copy) */ +static void +merge_hashes(HV* in, HV* out) { + HE* he; + + hv_iterinit(in); + while ((he = hv_iternext(in))) { + if (!hv_store_ent(out, HeSVKEY_force(he), + SvREFCNT_inc(HeVAL(he)), HeHASH(he))) { + SvREFCNT_dec(HeVAL(he)); + croak("Cannot add new key to hash"); + } + } +} + +/* convert array to hash */ +static IV +convert_array2hash(AV* in, HV* options, HV* out) { + IV i; + I32 len; + + len = av_len(in); + if (len > -1 && len % 2 != 1) { + SV* buffer = newSVpv("Odd number of parameters in call to ", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " when named parameters were expected\n"); + + validation_failure(buffer, options); + } + + for (i = 0; i <= av_len(in); i += 2) { + SV* key; + SV* value; + + key = *av_fetch(in, i, 1); + if (! key) { + continue; + } + + SvGETMAGIC(key); + + /* We need to make a copy because if the array was @_, then the + values in the array are marked as readonly, which causes + problems when the hash being made gets returned to the + caller. */ + value = sv_2mortal( newSVsv( *av_fetch(in, i + 1, 1) ) ); + + if (value) { + SvGETMAGIC(value); + } + + if (! hv_store_ent(out, key, SvREFCNT_inc(value), 0)) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + return 1; +} + +/* get current Params::Validate options */ +static HV* +get_options(HV* options) { + HV* OPTIONS; + HV* ret; + HE *he; + HV *stash; + SV* pkg; + SV *pkg_options; + + ret = (HV*) sv_2mortal((SV*) newHV()); + + /* get package specific options */ + stash = CopSTASH(PL_curcop); + pkg = sv_2mortal(newSVpv(HvNAME(stash), 0)); + + OPTIONS = get_hv("Params::Validate::OPTIONS", 1); + if ((he = hv_fetch_ent(OPTIONS, pkg, 0, 0))) { + pkg_options = HeVAL(he); + SvGETMAGIC(pkg_options); + if (SvROK(pkg_options) && SvTYPE(SvRV(pkg_options)) == SVt_PVHV) { + if (options) { + merge_hashes((HV*) SvRV(pkg_options), ret); + } + else { + return (HV*) SvRV(pkg_options); + } + } + } + if (options) { + merge_hashes(options, ret); + } + + return ret; +} + +static SV* +normalize_one_key(SV* key, SV* normalize_func, SV* strip_leading, IV ignore_case) { + SV* copy; + STRLEN len_sl; + STRLEN len; + char *rawstr_sl; + char *rawstr; + + copy = sv_2mortal(newSVsv(key)); + + /* if normalize_func is provided, ignore the other options */ + if (normalize_func) { + dSP; + + SV* normalized; + + PUSHMARK(SP); + XPUSHs(copy); + PUTBACK; + if (! call_sv(SvRV(normalize_func), G_SCALAR)) { + croak("The normalize_keys callback did not return anything"); + } + SPAGAIN; + normalized = POPs; + PUTBACK; + + if (! SvOK(normalized)) { + croak("The normalize_keys callback did not return a defined value when normalizing the key '%s'", SvPV_nolen(copy)); + } + + return normalized; + } + else if (ignore_case || strip_leading) { + if (ignore_case) { + STRLEN i; + + rawstr = SvPV(copy, len); + for (i = 0; i < len; i++) { + /* should this account for UTF8 strings? */ + *(rawstr + i) = toLOWER(*(rawstr + i)); + } + } + + if (strip_leading) { + rawstr_sl = SvPV(strip_leading, len_sl); + rawstr = SvPV(copy, len); + + if (len > len_sl && strnEQ(rawstr_sl, rawstr, len_sl)) { + copy = sv_2mortal(newSVpvn(rawstr + len_sl, len - len_sl)); + } + } + } + + return copy; +} + +static HV* +normalize_hash_keys(HV* p, SV* normalize_func, SV* strip_leading, IV ignore_case) { + SV* normalized; + HE* he; + HV* norm_p; + + if (!normalize_func && !ignore_case && !strip_leading) { + return p; + } + + norm_p = (HV*) sv_2mortal((SV*) newHV()); + hv_iterinit(p); + while ((he = hv_iternext(p))) { + normalized = + normalize_one_key(HeSVKEY_force(he), normalize_func, strip_leading, ignore_case); + + if (hv_fetch_ent(norm_p, normalized, 0, 0)) { + croak("The normalize_keys callback returned a key that already exists, '%s', when normalizing the key '%s'", + SvPV_nolen(normalized), SvPV_nolen(HeSVKEY_force(he))); + } + + if (! hv_store_ent(norm_p, normalized, SvREFCNT_inc(HeVAL(he)), 0)) { + SvREFCNT_dec(HeVAL(he)); + croak("Cannot add new key to hash"); + } + } + return norm_p; +} + +static IV +validate_pos_depends(AV* p, AV* specs, HV* options) { + IV p_idx; + SV** depends; + SV** p_spec; + + for (p_idx = 0; p_idx <= av_len(p); p_idx++) { + p_spec = av_fetch(specs, p_idx, 0); + + if (p_spec != NULL && SvROK(*p_spec) && + SvTYPE(SvRV(*p_spec)) == SVt_PVHV) { + + depends = hv_fetch((HV*) SvRV(*p_spec), "depends", 7, 0); + + if (! depends) { + return 1; + } + + if (SvROK(*depends)) { + croak("Arguments to 'depends' for validate_pos() must be a scalar"); + } + + if (av_len(p) < SvIV(*depends) -1) { + SV *buffer = + newSVpvf("Parameter #%d depends on parameter #%d, which was not given", + (int) p_idx + 1, + (int) SvIV(*depends)); + + validation_failure(buffer, options); + } + } + } + + return 1; +} + +static IV +validate_named_depends(HV* p, HV* specs, HV* options) { + HE* he; + HE* he1; + SV* buffer; + SV** depends_value; + AV* depends_list; + SV* depend_name; + SV* temp; + I32 d_idx; + + /* the basic idea here is to iterate through the parameters + * (which we assumed to have already gone through validation + * via validate_one_param()), and the check to see if that + * parameter contains a "depends" spec. If it does, we'll + * check if that parameter specified by depends exists in p + */ + hv_iterinit(p); + while ((he = hv_iternext(p))) { + he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he)); + + if (he1 && SvROK(HeVAL(he1)) && + SvTYPE(SvRV(HeVAL(he1))) == SVt_PVHV) { + + if (hv_exists((HV*) SvRV(HeVAL(he1)), "depends", 7)) { + + depends_value = hv_fetch((HV*) SvRV(HeVAL(he1)), "depends", 7, 0); + + if (! depends_value) { + return 1; + } + + if (! SvROK(*depends_value)) { + depends_list = (AV*) sv_2mortal((SV*) newAV()); + temp = sv_2mortal(newSVsv(*depends_value)); + av_push(depends_list,SvREFCNT_inc(temp)); + } + else if (SvTYPE(SvRV(*depends_value)) == SVt_PVAV) { + depends_list = (AV*) SvRV(*depends_value); + } + else { + croak("Arguments to 'depends' must be a scalar or arrayref"); + } + + for (d_idx =0; d_idx <= av_len(depends_list); d_idx++) { + + depend_name = *av_fetch(depends_list, d_idx, 0); + + /* first check if the parameter to which this + * depends on was given to us + */ + if (!hv_exists(p, SvPV_nolen(depend_name), + SvCUR(depend_name))) { + /* oh-oh, the parameter that this parameter + * depends on is not available. Let's first check + * if this is even valid in the spec (i.e., the + * spec actually contains a spec for such parameter) + */ + if (!hv_exists(specs, SvPV_nolen(depend_name), + SvCUR(depend_name))) { + + buffer = + sv_2mortal(newSVpv("Following parameter specified in depends for '", 0)); + + sv_catsv(buffer, HeSVKEY_force(he1)); + sv_catpv(buffer, "' does not exist in spec: "); + sv_catsv(buffer, depend_name); + + croak("%s", SvPV_nolen(buffer)); + } + /* if we got here, the spec was correct. we just + * need to issue a regular validation failure + */ + buffer = newSVpv( "Parameter '", 0); + sv_catsv(buffer, HeSVKEY_force(he1)); + sv_catpv(buffer, "' depends on parameter '"); + sv_catsv(buffer, depend_name); + sv_catpv(buffer, "', which was not given"); + validation_failure(buffer, options); + } + } + } + } + } + return 1; +} + +void +apply_defaults(HV *ret, HV *p, HV *specs, AV *missing) { + HE* he; + SV** temp; + + hv_iterinit(specs); + while ((he = hv_iternext(specs))) { + HV* spec; + SV* val; + + val = HeVAL(he); + + /* get extended param spec if available */ + if (val && SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) { + spec = (HV*) SvRV(val); + } + else { + spec = NULL; + } + + /* test for parameter existence */ + if (hv_exists_ent(p, HeSVKEY_force(he), HeHASH(he))) { + continue; + } + + /* parameter may not be defined but we may have default */ + if (spec && (temp = hv_fetch(spec, "default", 7, 0))) { + SV* value; + + SvGETMAGIC(*temp); + value = sv_2mortal(newSVsv(*temp)); + + /* make sure that parameter is put into return hash */ + if (GIMME_V != G_VOID) { + if (!hv_store_ent(ret, HeSVKEY_force(he), + SvREFCNT_inc(value), HeHASH(he))) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + continue; + } + + /* find if missing parameter is mandatory */ + if (! no_validation()) { + SV** temp; + + if (spec) { + if ((temp = hv_fetch(spec, "optional", 8, 0))) { + SvGETMAGIC(*temp); + + if (SvTRUE(*temp)) continue; + } + } + else if (!SvTRUE(HeVAL(he))) { + continue; + } + av_push(missing, SvREFCNT_inc(HeSVKEY_force(he))); + } + } +} + +static IV +validate(HV* p, HV* specs, HV* options, HV* ret) { + AV* missing; + AV* unmentioned; + HE* he; + HE* he1; + SV* hv; + SV* hv1; + IV ignore_case = 0; + SV* strip_leading = NULL; + IV allow_extra = 0; + SV** temp; + SV* normalize_func = NULL; + AV* untaint_keys = (AV*) sv_2mortal((SV*) newAV()); + IV i; + + if ((temp = hv_fetch(options, "ignore_case", 11, 0))) { + SvGETMAGIC(*temp); + ignore_case = SvTRUE(*temp); + } + + if ((temp = hv_fetch(options, "strip_leading", 13, 0))) { + SvGETMAGIC(*temp); + if (SvOK(*temp)) strip_leading = *temp; + } + + if ((temp = hv_fetch(options, "normalize_keys", 14, 0))) { + SvGETMAGIC(*temp); + if(SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVCV) { + normalize_func = *temp; + } + } + + if (normalize_func || ignore_case || strip_leading) { + p = normalize_hash_keys(p, normalize_func, strip_leading, ignore_case); + specs = normalize_hash_keys(specs, normalize_func, strip_leading, ignore_case); + } + + /* short-circuit everything else when no_validation is true */ + if (no_validation()) { + if (GIMME_V != G_VOID) { + while ((he = hv_iternext(p))) { + hv = HeVAL(he); + if (! hv) { + continue; + } + + SvGETMAGIC(hv); + + /* put the parameter into return hash */ + if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv), + HeHASH(he))) { + SvREFCNT_dec(hv); + croak("Cannot add new key to hash"); + } + } + apply_defaults(ret, p, specs, NULL); + } + + return 1; + } + + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + + /* find extra parameters and validate good parameters */ + unmentioned = (AV*) sv_2mortal((SV*) newAV()); + + hv_iterinit(p); + while ((he = hv_iternext(p))) { + hv = HeVAL(he); + if (! hv) { + continue; + } + + SvGETMAGIC(hv); + + /* put the parameter into return hash */ + if (GIMME_V != G_VOID) { + if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv), + HeHASH(he))) { + SvREFCNT_dec(hv); + croak("Cannot add new key to hash"); + } + } + + /* check if this parameter is defined in spec and if it is + then validate it using spec */ + he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he)); + if(he1) { + hv1 = HeVAL(he1); + if (SvROK(hv1) && SvTYPE(SvRV(hv1)) == SVt_PVHV) { + char* buffer; + HV* spec; + IV untaint = 0; + + spec = (HV*) SvRV(hv1); + buffer = form("The '%s' parameter (%%s)", HePV(he, PL_na)); + + if (! validate_one_param(hv, (SV*) p, spec, buffer, options, &untaint)) + return 0; + + /* The value stored here is meaningless, we're just tracking + keys to untaint later */ + if (untaint) { + av_push(untaint_keys, SvREFCNT_inc(HeSVKEY_force(he1))); + } + } + } + else if (! allow_extra) { + av_push(unmentioned, SvREFCNT_inc(HeSVKEY_force(he))); + } + + if (av_len(unmentioned) > -1) { + SV* buffer = newSVpv("The following parameter", 0); + SV *caller = get_caller(options); + + if (av_len(unmentioned) != 0) { + sv_catpv(buffer, "s were "); + } + else { + sv_catpv(buffer, " was "); + } + sv_catpv(buffer, "passed in the call to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " but "); + if (av_len(unmentioned) != 0) { + sv_catpv(buffer, "were "); + } + else { + sv_catpv(buffer, "was "); + } + sv_catpv(buffer, "not listed in the validation options: "); + for(i = 0; i <= av_len(unmentioned); i++) { + sv_catsv(buffer, *av_fetch(unmentioned, i, 1)); + if (i < av_len(unmentioned)) { + sv_catpv(buffer, " "); + } + } + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + } + + validate_named_depends(p, specs, options); + + /* find missing parameters */ + missing = (AV*) sv_2mortal((SV*) newAV()); + + apply_defaults(ret, p, specs, missing); + + if (av_len(missing) > -1) { + SV* buffer = newSVpv("Mandatory parameter", 0); + SV *caller = get_caller(options); + + if (av_len(missing) > 0) { + sv_catpv(buffer, "s "); + } + else { + sv_catpv(buffer, " "); + } + + for(i = 0; i <= av_len(missing); i++) { + sv_catpvf(buffer, "'%s'", + SvPV_nolen(*av_fetch(missing, i, 0))); + if (i < av_len(missing)) { + sv_catpv(buffer, ", "); + } + } + sv_catpv(buffer, " missing in call to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + + if (GIMME_V != G_VOID) { + for (i = 0; i <= av_len(untaint_keys); i++) { + SvTAINTED_off(HeVAL(hv_fetch_ent(p, *av_fetch(untaint_keys, i, 0), 0, 0))); + } + } + + return 1; +} + +static SV* +validate_pos_failure(IV pnum, IV min, IV max, HV* options) { + SV* buffer; + SV** temp; + IV allow_extra; + + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + else { + allow_extra = 0; + } + + buffer = newSViv(pnum + 1); + if (pnum != 0) { + sv_catpv(buffer, " parameters were passed to "); + } + else { + sv_catpv(buffer, " parameter was passed to "); + } + sv_catsv(buffer, get_caller(options)); + sv_catpv(buffer, " but "); + if (!allow_extra) { + if (min != max) { + sv_catpvf(buffer, "%d - %d", (int) min + 1, (int) max + 1); + } + else { + sv_catpvf(buffer, "%d", (int) max + 1); + } + } + else { + sv_catpvf(buffer, "at least %d", (int) min + 1); + } + if ((allow_extra ? min : max) != 0) { + sv_catpv(buffer, " were expected\n"); + } + else { + sv_catpv(buffer, " was expected\n"); + } + + return buffer; +} + +/* Given a single parameter spec and a corresponding complex spec form + of it (which must be false if the spec is not complex), return true + says that the parameter is options. */ +static bool +spec_says_optional(SV* spec, IV complex_spec) { + SV** temp; + + if (complex_spec) { + if ((temp = hv_fetch((HV*) SvRV(spec), "optional", 8, 0))) { + SvGETMAGIC(*temp); + if (!SvTRUE(*temp)) + return FALSE; + } + else { + return FALSE; + } + } + else { + if (SvTRUE(spec)) { + return FALSE; + } + } + return TRUE; +} + +static IV +validate_pos(AV* p, AV* specs, HV* options, AV* ret) { + char* buffer; + SV* value; + SV* spec = NULL; + SV** temp; + IV i; + IV complex_spec = 0; + IV allow_extra; + /* Index of highest-indexed required parameter known so far, or -1 + if no required parameters are known yet. */ + IV min = -1; + AV* untaint_indexes = (AV*) sv_2mortal((SV*) newAV()); + + if (no_validation()) { + IV spec_count = av_len(specs); + IV p_count = av_len(p); + IV max = spec_count > p_count ? spec_count : p_count; + + if (GIMME_V == G_VOID) { + return 1; + } + + for (i = 0; i <= max; i++) { + if (i <= spec_count) { + spec = *av_fetch(specs, i, 1); + if (spec) { + SvGETMAGIC(spec); + } + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + } + + if (i <= av_len(p)) { + value = *av_fetch(p, i, 1); + SvGETMAGIC(value); + av_push(ret, SvREFCNT_inc(value)); + } else if (complex_spec && + (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) { + SvGETMAGIC(*temp); + av_push(ret, SvREFCNT_inc(*temp)); + } + } + return 1; + } + + /* iterate through all parameters and validate them */ + for (i = 0; i <= av_len(specs); i++) { + spec = *av_fetch(specs, i, 1); + if (! spec) { + continue; + } + SvGETMAGIC(spec); + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + + /* Unless the current spec refers to an optional argument, update + our notion of the index of the highest-idexed required + parameter. */ + if (! spec_says_optional(spec, complex_spec) ) { + min = i; + } + + if (i <= av_len(p)) { + value = *av_fetch(p, i, 1); + SvGETMAGIC(value); + + if (complex_spec) { + IV untaint = 0; + + buffer = form("Parameter #%d (%%s)", (int)i + 1); + + if (! validate_one_param(value, (SV*) p, (HV*) SvRV(spec), buffer, options, &untaint)) { + return 0; + } + + if (untaint) { + av_push(untaint_indexes, newSViv(i)); + } + } + + if (GIMME_V != G_VOID) { + av_push(ret, SvREFCNT_inc(value)); + } + + } else if (complex_spec && + (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) { + SvGETMAGIC(*temp); + + if (GIMME_V != G_VOID) { + av_store(ret, i, SvREFCNT_inc(*temp)); + } + + } + else { + if (i == min) { + /* We don't have as many arguments as the arg spec requires. */ + SV* buffer; + + /* Look forward through remaining argument specifications to + find the last non-optional one, so we can correctly report the + number of arguments required. */ + for (i++ ; i <= av_len(specs); i++) { + spec = *av_fetch(specs, i, 1); + if (! spec) { + continue; + } + + SvGETMAGIC(spec); + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + if (! spec_says_optional(spec, complex_spec)) { + min = i; + } + if (min != i) + break; + } + + buffer = validate_pos_failure(av_len(p), min, av_len(specs), options); + + validation_failure(buffer, options); + } + } + } + + validate_pos_depends(p, specs, options); + + /* test for extra parameters */ + if (av_len(p) > av_len(specs)) { + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + else { + allow_extra = 0; + } + if (allow_extra) { + /* put all additional parameters into return array */ + if (GIMME_V != G_VOID) { + for(i = av_len(specs) + 1; i <= av_len(p); i++) { + value = *av_fetch(p, i, 1); + if (value) { + SvGETMAGIC(value); + av_push(ret, SvREFCNT_inc(value)); + } + else { + av_push(ret, &PL_sv_undef); + } + } + } + } + else { + SV* buffer = validate_pos_failure(av_len(p), min, av_len(specs), options); + validation_failure(buffer, options); + } + } + + if (GIMME_V != G_VOID) { + for (i = 0; i <= av_len(untaint_indexes); i++) { + SvTAINTED_off(*av_fetch(p, SvIV(*av_fetch(untaint_indexes, i, 0)), 0)); + } + } + + return 1; +} + +MODULE = Params::Validate::XS PACKAGE = Params::Validate::XS + +void +validate(p, specs) + SV* p + SV* specs + + PROTOTYPE: \@$ + + PPCODE: + + HV* ret = NULL; + AV* pa; + HV* ph; + HV* options; + + if (no_validation() && GIMME_V == G_VOID) { + XSRETURN(0); + } + + SvGETMAGIC(p); + if (! (SvROK(p) && SvTYPE(SvRV(p)) == SVt_PVAV)) { + croak("Expecting array reference as first parameter"); + } + + SvGETMAGIC(specs); + if (! (SvROK(specs) && SvTYPE(SvRV(specs)) == SVt_PVHV)) { + croak("Expecting hash reference as second parameter"); + } + + pa = (AV*) SvRV(p); + ph = NULL; + if (av_len(pa) == 0) { + /* we were called as validate( @_, ... ) where @_ has a + single element, a hash reference */ + SV* value; + + value = *av_fetch(pa, 0, 1); + if (value) { + SvGETMAGIC(value); + if (SvROK(value) && SvTYPE(SvRV(value)) == SVt_PVHV) { + ph = (HV*) SvRV(value); + } + } + } + + options = get_options(NULL); + + if (! ph) { + ph = (HV*) sv_2mortal((SV*) newHV()); + + if (! convert_array2hash(pa, options, ph) ) { + XSRETURN(0); + } + } + if (GIMME_V != G_VOID) { + ret = (HV*) sv_2mortal((SV*) newHV()); + } + if (! validate(ph, (HV*) SvRV(specs), options, ret)) { + XSRETURN(0); + } + RETURN_HASH(ret); + +void +validate_pos(p, ...) +SV* p + + PROTOTYPE: \@@ + + PPCODE: + + AV* specs; + AV* ret = NULL; + IV i; + + if (no_validation() && GIMME_V == G_VOID) { + XSRETURN(0); + } + + SvGETMAGIC(p); + if (!SvROK(p) || !(SvTYPE(SvRV(p)) == SVt_PVAV)) { + croak("Expecting array reference as first parameter"); + } + + specs = (AV*) sv_2mortal((SV*) newAV()); + av_extend(specs, items); + for(i = 1; i < items; i++) { + if (!av_store(specs, i - 1, SvREFCNT_inc(ST(i)))) { + SvREFCNT_dec(ST(i)); + croak("Cannot store value in array"); + } + } + + if (GIMME_V != G_VOID) { + ret = (AV*) sv_2mortal((SV*) newAV()); + } + + if (! validate_pos((AV*) SvRV(p), specs, get_options(NULL), ret)) { + XSRETURN(0); + } + + RETURN_ARRAY(ret); + +void +validate_with(...) + + PPCODE: + + HV* p; + SV* params; + SV* spec; + IV i; + + if (no_validation() && GIMME_V == G_VOID) XSRETURN(0); + + /* put input list into hash */ + p = (HV*) sv_2mortal((SV*) newHV()); + for(i = 0; i < items; i += 2) { + SV* key; + SV* value; + + key = ST(i); + if (i + 1 < items) { + value = ST(i + 1); + } + else { + value = &PL_sv_undef; + } + if (! hv_store_ent(p, key, SvREFCNT_inc(value), 0)) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + params = *hv_fetch(p, "params", 6, 1); + SvGETMAGIC(params); + spec = *hv_fetch(p, "spec", 4, 1); + SvGETMAGIC(spec); + + if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVAV) { + if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) { + AV* ret = NULL; + + if (GIMME_V != G_VOID) { + ret = (AV*) sv_2mortal((SV*) newAV()); + } + + PUTBACK; + + if (! validate_pos((AV*) SvRV(params), (AV*) SvRV(spec), get_options(p), ret)) { + SPAGAIN; + XSRETURN(0); + } + + SPAGAIN; + RETURN_ARRAY(ret); + } + else { + croak("Expecting array reference in 'params'"); + } + } + else if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV) { + HV* hv; + HV* ret = NULL; + HV* options; + + options = get_options(p); + + if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVHV) { + hv = (HV*) SvRV(params); + } + else if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) { + I32 hv_set = 0; + + /* Check to see if we have a one element array + containing a hash reference */ + if (av_len((AV*) SvRV(params)) == 0) { + SV** first_elem; + + first_elem = av_fetch((AV*) SvRV(params), 0, 0); + + if (first_elem && SvROK(*first_elem) && + SvTYPE(SvRV(*first_elem)) == SVt_PVHV) { + + hv = (HV*) SvRV(*first_elem); + hv_set = 1; + } + } + + if (! hv_set) { + hv = (HV*) sv_2mortal((SV*) newHV()); + + if (! convert_array2hash((AV*) SvRV(params), options, hv)) + XSRETURN(0); + } + } + else { + croak("Expecting array or hash reference in 'params'"); + } + + if (GIMME_V != G_VOID) { + ret = (HV*) sv_2mortal((SV*) newHV()); + } + + PUTBACK; + + if (! validate(hv, (HV*) SvRV(spec), options, ret)) { + SPAGAIN; + XSRETURN(0); + } + + SPAGAIN; + RETURN_HASH(ret); + } + else { + croak("Expecting array or hash reference in 'spec'"); + } diff --git a/lib/Params/ValidatePP.pm b/lib/Params/ValidatePP.pm new file mode 100644 index 0000000..9740cc9 --- /dev/null +++ b/lib/Params/ValidatePP.pm @@ -0,0 +1,9 @@ +package # hide from PAUSE + Params::Validate; + +our $VERSION = '1.20'; + +BEGIN { $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'PP' } +use Params::Validate; + +1; diff --git a/lib/Params/ValidateXS.pm b/lib/Params/ValidateXS.pm new file mode 100644 index 0000000..4f07801 --- /dev/null +++ b/lib/Params/ValidateXS.pm @@ -0,0 +1,9 @@ +package # hide from PAUSE + Params::Validate; + +our $VERSION = '1.20'; + +BEGIN { $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS' } +use Params::Validate; + +1; |