From: Dave Rolsky Date: Wed, 9 Dec 2009 19:19:17 +0000 (-0600) Subject: copied from svn X-Git-Tag: 0.14~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9d1529df9e8c52248cdd0bac2de23d235af3a0b;p=gitmo%2FMooseX-Params-Validate.git copied from svn --- d9d1529df9e8c52248cdd0bac2de23d235af3a0b diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..9ba422b --- /dev/null +++ b/ChangeLog @@ -0,0 +1,84 @@ +Revision history for Perl extension MooseX-Params-Validate + +0.13 Sun., Nov. 29, 2009 + - Fix so that validated_hash does not try to coerce optional + parameters which are not present. Patch by Ian Sillitoe. + + - Same fix for pos_validated_list. (Dave Rolsky) + +0.12 Tue. Jul. 7, 2009 + - Using the subroutine name as a cache key for validation specs + broke in the face of method modifiers, which all appear to have + the same name. Now we use Devel::Caller to get the CV of the + caller and use its refaddr as the key, which will be unique in + all cases. Bug report by Jos Boumans. RT #46730. + +0.11 Tue. Jul. 7, 2009 + - The validation functions tried to coerce optional keys which + weren't present in the incoming parameters, leading to weird + errors. Based on a patch from Jos Boumans. RT #46344. + + - Allow other callbacks to be specified. Previously these were + silently thrown out. But we'd recommend just defining types that + encapsulate everything in the callback instead. Based on a patch + from Jos Boumans. RT #47647. + +0.10 Tue. Jun. 30, 2009 + - Shut up deprecation warnings from the tests. Reported by John + Goulah. + +0.09 Sun. Feb. 1, 2009 + - The subroutine name being reported in error messages was screwy. + +0.08 Sun. Feb. 1, 2009 + - Renamed validate to validated_hash and validatep to + validated_list. The old function names are still available under + the ":deprecated" import tag. + + - Added a new pos_validated_list which can validate position + parameters. + + - Errors now reflect the subroutine that called the validation + function, rather than coming form inside the validation function + itself. + +0.07 Sun. Sep. 21, 2008 + - No code changes, just fixing missing prereqs (Dave Rolsky) + +0.06 Sat. Sep. 20, 2008 + - Fixes to work with Moose 0.58 (Dave Rolsky) + + - Switched to using Module::Install (Dave Rolsky) + +0.05 Fri. Mar. 7th, 2008 + - This package would cause a fatal error if loaded + by a non-Moose class (Dave Rolsky) + - added tests for this (Dave Rolsky) + + - Added support for coercions (Dave Rolsky) + +0.04 Tues. Jan. 8th, 2008 + - upped the Moose dependency and added support + for the new improved Moose type constraints + - added tests for this + + - adding caching of the prepared parameter + specs, this results in approx. 3x speedup + using rough benchmarks. + + - added special caching handlers see the + IMPORTANT NOTE ON CACHING section of the + POD for more details + - added tests for this + +0.03 Fri. June 8th, 2007 + - added support for using this + within role methods too. + +0.02 Wed. April 25, 2007 + - added validatep, which returns the captured + args as positional instead of as hash + - added docs and tests + +0.01 Wed. April 18, 2007 + - trying to fill a gap, we will see ... diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..cb67169 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,20 @@ +^_build +^Build$ +^blib +~$ +\.bak$ +^MANIFEST\.SKIP$ +CVS +\.svn +\.DS_Store +cover_db +\..*\.sw.?$ +^Makefile$ +^pm_to_blib$ +^MakeMaker-\d +^blibdirs$ +\.old$ +^#.*#$ +^\.# +^TODO$ +^\.shipit diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..e2efe9d --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,23 @@ +use strict; +use warnings; +use inc::Module::Install 0.91; + +name 'MooseX-Params-Validate'; +all_from 'lib/MooseX/Params/Validate.pm'; + + +requires 'Carp' => '0'; +requires 'Devel::Caller' => '0'; +requires 'Moose' => '0.58'; +requires 'Params::Validate' => '0.88'; +requires 'Scalar::Util' => '0'; +requires 'Sub::Exporter' => '0'; + +build_requires 'Test::More' => '0.62'; +build_requires 'Test::Exception' => '0.21'; + +license 'Perl'; + +resources repository => 'http://code2.0beta.co.uk/moose/svn/MooseX-Params-Validate'; + +WriteAll(); diff --git a/README b/README new file mode 100644 index 0000000..4053bcb --- /dev/null +++ b/README @@ -0,0 +1,30 @@ +MooseX::Params::Validate version 0.13 +=========================== + +See the individual module documentation for more information + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + Moose + Params::Validate + +COPYRIGHT AND LICENCE + +Copyright (C) 2007-2008 Infinity Interactive, Inc. + +http://www.iinteractive.com + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/lib/MooseX/Params/Validate.pm b/lib/MooseX/Params/Validate.pm new file mode 100644 index 0000000..56ebdbc --- /dev/null +++ b/lib/MooseX/Params/Validate.pm @@ -0,0 +1,466 @@ +package MooseX::Params::Validate; + +use strict; +use warnings; + +use Carp 'confess'; +use Devel::Caller 'caller_cv'; +use Scalar::Util 'blessed', 'refaddr'; + +use Moose::Util::TypeConstraints qw( find_type_constraint class_type role_type ); +use Params::Validate (); +use Sub::Exporter -setup => { + exports => [ + qw( validated_hash validated_list pos_validated_list validate validatep ) + ], + groups => { + default => [qw( validated_hash validated_list pos_validated_list )], + deprecated => [qw( validate validatep )], + }, +}; + +our $VERSION = '0.13'; +our $AUTHORITY = 'cpan:STEVAN'; + +my %CACHED_SPECS; + +sub validated_hash { + my ( $args, %spec ) = @_; + + my $cache_key = _cache_key( \%spec ); + + if ( exists $CACHED_SPECS{$cache_key} ) { + ( ref $CACHED_SPECS{$cache_key} eq 'HASH' ) + || confess + "I was expecting a HASH-ref in the cached $cache_key parameter" + . " spec, you are doing something funky, stop it!"; + %spec = %{ $CACHED_SPECS{$cache_key} }; + } + else { + my $should_cache = delete $spec{MX_PARAMS_VALIDATE_NO_CACHE} ? 0 : 1; + + $spec{$_} = _convert_to_param_validate_spec( $spec{$_} ) + foreach keys %spec; + + $CACHED_SPECS{$cache_key} = \%spec + if $should_cache; + } + + my $instance; + $instance = shift @$args if blessed $args->[0]; + + my %args = @$args; + + $args{$_} = $spec{$_}{constraint}->coerce( $args{$_} ) + for grep { $spec{$_}{coerce} && exists $args{$_} } keys %spec; + + %args = Params::Validate::validate_with( + params => \%args, + spec => \%spec, + called => _caller_name(), + ); + + return ( ( defined $instance ? $instance : () ), %args ); +} + +*validate = \&validated_hash; + +sub validated_list { + my ( $args, @spec ) = @_; + + my %spec = @spec; + + my $cache_key = _cache_key( \%spec ); + + my @ordered_spec; + if ( exists $CACHED_SPECS{$cache_key} ) { + ( ref $CACHED_SPECS{$cache_key} eq 'ARRAY' ) + || confess + "I was expecting a ARRAY-ref in the cached $cache_key parameter" + . " spec, you are doing something funky, stop it!"; + %spec = %{ $CACHED_SPECS{$cache_key}->[0] }; + @ordered_spec = @{ $CACHED_SPECS{$cache_key}->[1] }; + } + else { + my $should_cache = delete $spec{MX_PARAMS_VALIDATE_NO_CACHE} ? 0 : 1; + + @ordered_spec = grep { exists $spec{$_} } @spec; + + $spec{$_} = _convert_to_param_validate_spec( $spec{$_} ) + foreach keys %spec; + + $CACHED_SPECS{$cache_key} = [ \%spec, \@ordered_spec ] + if $should_cache; + } + + my $instance; + $instance = shift @$args if blessed $args->[0]; + + my %args = @$args; + + $args{$_} = $spec{$_}{constraint}->coerce( $args{$_} ) + for grep { $spec{$_}{coerce} && exists $args{$_} } keys %spec; + + %args = Params::Validate::validate_with( + params => \%args, + spec => \%spec, + called => _caller_name(), + ); + + return ( + ( defined $instance ? $instance : () ), + @args{@ordered_spec} + ); +} + +*validatep = \&validated_list; + +sub pos_validated_list { + my $args = shift; + + my @spec; + push @spec, shift while ref $_[0]; + + my %extra = @_; + + my $cache_key = _cache_key( \%extra ); + + my @pv_spec; + if ( exists $CACHED_SPECS{$cache_key} ) { + ( ref $CACHED_SPECS{$cache_key} eq 'ARRAY' ) + || confess + "I was expecting an ARRAY-ref in the cached $cache_key parameter" + . " spec, you are doing something funky, stop it!"; + @pv_spec = @{ $CACHED_SPECS{$cache_key} }; + } + else { + my $should_cache = exists $extra{MX_PARAMS_VALIDATE_NO_CACHE} ? 0 : 1; + + # prepare the parameters ... + @pv_spec = map { _convert_to_param_validate_spec($_) } @spec; + + $CACHED_SPECS{$cache_key} = \@pv_spec + if $should_cache; + } + + my @args = @{$args}; + + $args[$_] = $pv_spec[$_]{constraint}->coerce( $args[$_] ) + for grep { $pv_spec[$_] && $pv_spec[$_]{coerce} } 0 .. $#args; + + @args = Params::Validate::validate_with( + params => \@args, + spec => \@pv_spec, + called => _caller_name(), + ); + + return @args; +} + +sub _cache_key { + my $spec = shift; + + if ( exists $spec->{MX_PARAMS_VALIDATE_CACHE_KEY} ) { + return delete $spec->{MX_PARAMS_VALIDATE_CACHE_KEY}; + } + else { + return refaddr( caller_cv(2) ); + } +} + +sub _convert_to_param_validate_spec { + my ($spec) = @_; + my %pv_spec; + + $pv_spec{optional} = $spec->{optional} + if exists $spec->{optional}; + + $pv_spec{default} = $spec->{default} + if exists $spec->{default}; + + $pv_spec{coerce} = $spec->{coerce} + if exists $spec->{coerce}; + + my $constraint; + if ( defined $spec->{isa} ) { + $constraint + = _is_tc( $spec->{isa} ) + || Moose::Util::TypeConstraints::find_or_parse_type_constraint( + $spec->{isa} ) + || class_type( $spec->{isa} ); + } + elsif ( defined $spec->{does} ) { + $constraint + = _is_tc( $spec->{isa} ) + || find_type_constraint( $spec->{does} ) + || role_type( $spec->{does} ); + } + + $pv_spec{callbacks} = $spec->{callbacks} + if exists $spec->{callbacks}; + + if ($constraint) { + $pv_spec{constraint} = $constraint; + + $pv_spec{callbacks} + { 'checking type constraint for ' . $constraint->name } + = sub { $constraint->check( $_[0] ) }; + } + + delete $pv_spec{coerce} + unless $pv_spec{constraint} && $pv_spec{constraint}->has_coercion; + + return \%pv_spec; +} + +sub _is_tc { + my $maybe_tc = shift; + + return $maybe_tc + if defined $maybe_tc + && blessed $maybe_tc + && $maybe_tc->isa('Moose::Meta::TypeConstraint'); +} + +sub _caller_name { + my $depth = shift || 0; + + return ( caller( 2 + $depth ) )[3]; +} + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::Params::Validate - an extension of Params::Validate for using Moose's types + +=head1 SYNOPSIS + + package Foo; + use Moose; + use MooseX::Params::Validate; + + sub foo { + my ( $self, %params ) = validated_hash( + \@_, + bar => { isa => 'Str', default => 'Moose' }, + ); + return "Horray for $params{bar}!"; + } + + sub bar { + my $self = shift; + my ( $foo, $baz, $gorch ) = validated_list( + \@_, + foo => { isa => 'Foo' }, + baz => { isa => 'ArrayRef | HashRef', optional => 1 }, + gorch => { isa => 'ArrayRef[Int]', optional => 1 } + ); + [ $foo, $baz, $gorch ]; + } + +=head1 DESCRIPTION + +This module fills a gap in Moose by adding method parameter validation +to Moose. This is just one of many developing options, it should not +be considered the "official" one by any means though. + +You might also want to explore C and +C + +=head1 CAVEATS + +It is not possible to introspect the method parameter specs, they are +created as needed when the method is called and cached for subsequent +calls. + +=head1 EXPORTS + +=over 4 + +=item B + +This behaves similar to the standard Params::Validate C +function and returns the captured values in a HASH. The one exception +being that if it spots an instance in the C<@_>, then it will handle +it appropriately (unlike Params::Validate which forces you to shift +you C<$self> first). + +The C<%parameter_spec> accepts the following options: + +=over 4 + +=item I + +The C option can be either; class name, Moose type constraint +name or an anon Moose type constraint. + +=item I + +The C option can be either; role name or an anon Moose type +constraint. + +=item I + +This is the default value to be used if the value is not supplied. + +=item I + +As with Params::Validate, all options are considered required unless +otherwise specified. This option is passed directly to +Params::Validate. + +=item I + +If this is true and the parameter has a type constraint which has +coercions, then the coercion will be called for this parameter. If the +type does have coercions, then this parameter is ignored. + +=back + +This function is also available under its old name, C. + +=item B + +The C<%parameter_spec> accepts the same options as above, but returns +the parameters as positional values instead of a HASH. This is best +explained by example: + + sub foo { + my ( $self, $foo, $bar ) = validated_list( + \@_, + foo => { isa => 'Foo' }, + bar => { isa => 'Bar' }, + ); + $foo->baz($bar); + } + +We capture the order in which you defined the parameters and then +return them as a list in the same order. If a param is marked optional +and not included, then it will be set to C. + +Like C, if it spots an object instance as the first +parameter of C<@_>, it will handle it appropriately, returning it as +the first argument. + +This function is also available under its old name, C. + +=item B + +This function validates a list of positional parameters. Each C<$spec> +should validate one of the parameters in the list: + + sub foo { + my $self = shift; + my ( $foo, $bar ) = pos_validated_list( + \@_, + { isa => 'Foo' }, + { isa => 'Bar' }, + ); + + ... + } + +Unlike the other functions, this function I find C<$self> in +the argument list. Make sure to shift it off yourself before doing +validation. + +If a parameter is marked as optional and is not present, it will +simply not be returned. + +If you want to pass in any of the cache control parameters described +below, simply pass them after the list of parameter validation specs: + + sub foo { + my $self = shift; + my ( $foo, $bar ) = pos_validated_list( + \@_, + { isa => 'Foo' }, + { isa => 'Bar' }, + MX_PARAMS_VALIDATE_NO_CACHE => 1, + ); + + ... + } + +=back + +=head1 EXPORTS + +By default, this module exports the C, +C, and C. + +If you would prefer to import the now deprecated functions C +and C instead, you can use the C<:deprecated> tag to import +them. + +=head1 IMPORTANT NOTE ON CACHING + +When C or C are called the first time, the +parameter spec is prepared and cached to avoid unnecessary +regeneration. It uses the fully qualified name of the subroutine +(package + subname) as the cache key. In 99.999% of the use cases for +this module, that will be the right thing to do. + +However, I have (ab)used this module occasionally to handle dynamic +sets of parameters. In this special use case you can do a couple +things to better control the caching behavior. + +=over 4 + +=item * + +Passing in the C flag in the parameter +spec this will prevent the parameter spec from being cached. + + sub foo { + my ( $self, %params ) = validated_hash( + \@_, + foo => { isa => 'Foo' }, + MX_PARAMS_VALIDATE_NO_CACHE => 1, + ); + + } + +=item * + +Passing in C with a value to be used as +the cache key will bypass the normal cache key generation. + + sub foo { + my ( $self, %params ) = validated_hash( + \@_, + foo => { isa => 'Foo' }, + MX_PARAMS_VALIDATE_CACHE_KEY => 'foo-42', + ); + + } + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug to +cpan-RT. + +=head1 AUTHORS + +Stevan Little Estevan.little@iinteractive.comE + +Dave Rolsky Eautarch@urth.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/000_load.t b/t/000_load.t new file mode 100644 index 0000000..830b4bc --- /dev/null +++ b/t/000_load.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + # this module doesn't export to main + package Testing; + ::use_ok('MooseX::Params::Validate'); +} diff --git a/t/001_basic.t b/t/001_basic.t new file mode 100644 index 0000000..4bede46 --- /dev/null +++ b/t/001_basic.t @@ -0,0 +1,180 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 35; +use Test::Exception; + +{ + package Roles::Blah; + use Moose::Role; + use MooseX::Params::Validate; + + requires 'bar'; + requires 'baz'; + + sub foo { + my ( $self, %params ) = validated_hash( + \@_, + bar => { isa => 'Str', default => 'Moose' }, + ); + return "Horray for $params{bar}!"; + } + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use MooseX::Params::Validate; + + with 'Roles::Blah'; + + sub bar { + my $self = shift; + my %params = validated_hash( + \@_, + foo => { isa => 'Foo' }, + baz => { isa => 'ArrayRef | HashRef', optional => 1 }, + gorch => { isa => 'ArrayRef[Int]', optional => 1 }, + ); + [ $params{foo}, $params{baz}, $params{gorch} ]; + } + + sub baz { + my $self = shift; + my %params = validated_hash( + \@_, + foo => { + isa => subtype( 'Object' => where { $_->isa('Foo') } ), + optional => 1 + }, + bar => { does => 'Roles::Blah', optional => 1 }, + boo => { + does => role_type('Roles::Blah'), + optional => 1 + }, + ); + return $params{foo} || $params{bar} || $params{boo}; + } + + sub quux { + my $self = shift; + my %params = validated_hash( + \@_, + foo => { + isa => 'ArrayRef', + callbacks => { + 'some random callback' => sub { @{ $_[0] } <= 2 }, + }, + }, + ); + + return $params{foo}; + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +is( $foo->foo, 'Horray for Moose!', '... got the right return value' ); +is( $foo->foo( bar => 'Rolsky' ), 'Horray for Rolsky!', + '... got the right return value' ); + +is( $foo->baz( foo => $foo ), $foo, '... foo param must be a Foo instance' ); + +throws_ok { $foo->baz( foo => 10 ) } qr/\QThe 'foo' parameter ("10")/, + '... the foo param in &baz must be a Foo instance'; +throws_ok { $foo->baz( foo => "foo" ) } qr/\QThe 'foo' parameter ("foo")/, + '... the foo param in &baz must be a Foo instance'; +throws_ok { $foo->baz( foo => [] ) } qr/\QThe 'foo' parameter/, + '... the foo param in &baz must be a Foo instance'; + +is( $foo->baz( bar => $foo ), $foo, '... bar param must do Roles::Blah' ); + +throws_ok { $foo->baz( bar => 10 ) } qr/\QThe 'bar' parameter ("10")/, +'... the bar param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( bar => "foo" ) } qr/\QThe 'bar' parameter ("foo")/, +'... the bar param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( bar => [] ) } qr/\QThe 'bar' parameter/, +'... the bar param in &baz must be do Roles::Blah'; + +is( $foo->baz( boo => $foo ), $foo, '... boo param must do Roles::Blah' ); + +throws_ok { $foo->baz( boo => 10 ) } qr/\QThe 'boo' parameter ("10")/, +'... the boo param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( boo => "foo" ) } qr/\QThe 'boo' parameter ("foo")/, +'... the boo param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( boo => [] ) } qr/\QThe 'boo' parameter/, +'... the boo param in &baz must be do Roles::Blah'; + +throws_ok { $foo->bar } qr/\QMandatory parameter 'foo'/, + '... bar has a required param'; +throws_ok { $foo->bar( foo => 10 ) } qr/\QThe 'foo' parameter ("10")/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( foo => "foo" ) } qr/\QThe 'foo' parameter ("foo")/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( foo => [] ) } qr/\QThe 'foo' parameter/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( baz => [] ) } qr/\QMandatory parameter 'foo'/,, + '... bar has a required foo param'; + +is_deeply( + $foo->bar( foo => $foo ), + [ $foo, undef, undef ], + '... the foo param in &bar got a Foo instance' +); + +is_deeply( + $foo->bar( foo => $foo, baz => [] ), + [ $foo, [], undef ], + '... the foo param and baz param in &bar got a correct args' +); + +is_deeply( + $foo->bar( foo => $foo, baz => {} ), + [ $foo, {}, undef ], + '... the foo param and baz param in &bar got a correct args' +); + +throws_ok { $foo->bar( foo => $foo, baz => undef ) } +qr/\QThe 'baz' parameter (undef)/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => 10 ) } +qr/\QThe 'baz' parameter ("10")/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => 'Foo' ) } +qr/\QThe 'baz' parameter ("Foo")/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => \( my $var ) ) } +qr/\QThe 'baz' parameter/, + '... baz requires a ArrayRef | HashRef'; + +is_deeply( + $foo->bar( foo => $foo, gorch => [ 1, 2, 3 ] ), + [ $foo, undef, [ 1, 2, 3 ] ], + '... the foo param in &bar got a Foo instance' +); + +throws_ok { $foo->bar( foo => $foo, gorch => undef ) } +qr/\QThe 'gorch' parameter (undef)/, + '... gorch requires a ArrayRef[Int]'; +throws_ok { $foo->bar( foo => $foo, gorch => 10 ) } +qr/\QThe 'gorch' parameter ("10")/, + '... gorch requires a ArrayRef[Int]'; +throws_ok { $foo->bar( foo => $foo, gorch => 'Foo' ) } +qr/\QThe 'gorch' parameter ("Foo")/, + '... gorch requires a ArrayRef[Int]'; +throws_ok { $foo->bar( foo => $foo, gorch => \( my $var ) ) } +qr/\QThe 'gorch' parameter/, + '... gorch requires a ArrayRef[Int]'; +throws_ok { $foo->bar( foo => $foo, gorch => [qw/one two three/] ) } +qr/\QThe 'gorch' parameter/, + '... gorch requires a ArrayRef[Int]'; + +throws_ok { $foo->quux( foo => '123456790' ) } +qr/\QThe 'foo' parameter\E.+\Qchecking type constraint/, +'... foo parameter must be an ArrayRef'; + +throws_ok { $foo->quux( foo => [ 1, 2, 3, 4 ] ) } +qr/\QThe 'foo' parameter\E.+\Qsome random callback/, +'... foo parameter additional callback requires that arrayref be 0-2 elements'; diff --git a/t/002_basic_list.t b/t/002_basic_list.t new file mode 100644 index 0000000..b248919 --- /dev/null +++ b/t/002_basic_list.t @@ -0,0 +1,134 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 27; +use Test::Exception; + +{ + package Roles::Blah; + use Moose::Role; + + requires 'foo'; + requires 'bar'; + requires 'baz'; + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use MooseX::Params::Validate; + + with 'Roles::Blah'; + + sub foo { + my ( $self, $bar ) = validated_list( + \@_, + bar => { isa => 'Str', default => 'Moose' }, + ); + return "Horray for $bar!"; + } + + sub bar { + my $self = shift; + my ( $foo, $baz ) = validated_list( + \@_, + foo => { isa => 'Foo' }, + baz => { isa => 'ArrayRef | HashRef', optional => 1 }, + ); + [ $foo, $baz ]; + } + + sub baz { + my $self = shift; + my ( $foo, $bar, $boo ) = validated_list( + \@_, + foo => { + isa => subtype( 'Object' => where { $_->isa('Foo') } ), + optional => 1 + }, + bar => { does => 'Roles::Blah', optional => 1 }, + boo => { + does => role_type('Roles::Blah'), + optional => 1 + }, + ); + return $foo || $bar || $boo; + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +is( $foo->foo, 'Horray for Moose!', '... got the right return value' ); +is( $foo->foo( bar => 'Rolsky' ), 'Horray for Rolsky!', + '... got the right return value' ); + +is( $foo->baz( foo => $foo ), $foo, '... foo param must be a Foo instance' ); + +throws_ok { $foo->baz( foo => 10 ) } qr/\QThe 'foo' parameter ("10")/, + '... the foo param in &baz must be a Foo instance'; +throws_ok { $foo->baz( foo => "foo" ) } qr/\QThe 'foo' parameter ("foo")/, + '... the foo param in &baz must be a Foo instance'; +throws_ok { $foo->baz( foo => [] ) } qr/\QThe 'foo' parameter/, + '... the foo param in &baz must be a Foo instance'; + +is( $foo->baz( bar => $foo ), $foo, '... bar param must do Roles::Blah' ); + +throws_ok { $foo->baz( bar => 10 ) } qr/\QThe 'bar' parameter ("10")/, +'... the bar param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( bar => "foo" ) } qr/\QThe 'bar' parameter ("foo")/, +'... the bar param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( bar => [] ) } qr/\QThe 'bar' parameter/, +'... the bar param in &baz must be do Roles::Blah'; + +is( $foo->baz( boo => $foo ), $foo, '... boo param must do Roles::Blah' ); + +throws_ok { $foo->baz( boo => 10 ) } qr/\QThe 'boo' parameter ("10")/, +'... the boo param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( boo => "foo" ) } qr/\QThe 'boo' parameter ("foo")/, +'... the boo param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( boo => [] ) } qr/\QThe 'boo' parameter/, +'... the boo param in &baz must be do Roles::Blah'; + +throws_ok { $foo->bar } qr/\QMandatory parameter 'foo'/, + '... bar has a required param'; +throws_ok { $foo->bar( foo => 10 ) } qr/\QThe 'foo' parameter ("10")/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( foo => "foo" ) } qr/\QThe 'foo' parameter ("foo")/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( foo => [] ) } qr/\QThe 'foo' parameter/, + '... the foo param in &bar must be a Foo instance'; +throws_ok { $foo->bar( baz => [] ) } qr/\QMandatory parameter 'foo'/,, + '... bar has a required foo param'; + +is_deeply( + $foo->bar( foo => $foo ), + [ $foo, undef ], + '... the foo param in &bar got a Foo instance' +); + +is_deeply( + $foo->bar( foo => $foo, baz => [] ), + [ $foo, [] ], + '... the foo param and baz param in &bar got a correct args' +); + +is_deeply( + $foo->bar( foo => $foo, baz => {} ), + [ $foo, {} ], + '... the foo param and baz param in &bar got a correct args' +); + +throws_ok { $foo->bar( foo => $foo, baz => undef ) } +qr/\QThe 'baz' parameter (undef)/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => 10 ) } +qr/\QThe 'baz' parameter ("10")/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => 'Foo' ) } +qr/\QThe 'baz' parameter ("Foo")/, + '... baz requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( foo => $foo, baz => \( my $var ) ) } +qr/\QThe 'baz' parameter/, + '... baz requires a ArrayRef | HashRef'; diff --git a/t/003_nocache_flag.t b/t/003_nocache_flag.t new file mode 100644 index 0000000..a81b19a --- /dev/null +++ b/t/003_nocache_flag.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + +{ + package Foo; + use Moose; + use MooseX::Params::Validate; + + sub bar { + my ( $self, $args, $params ) = @_; + $params->{MX_PARAMS_VALIDATE_NO_CACHE}++; + return validated_hash( $args, %$params ); + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +lives_ok { + $foo->bar( [ baz => 1 ], { baz => { isa => 'Int' } } ); +} +'... successfully applied the parameter validation'; + +lives_ok { + $foo->bar( [ baz => [ 1, 2, 3 ] ], { baz => { isa => 'ArrayRef' } } ); +} +'... successfully applied the parameter validation (look mah no cache)'; + +lives_ok { + $foo->bar( [ baz => { one => 1 } ], { baz => { isa => 'HashRef' } } ); +} +'... successfully applied the parameter validation (look mah no cache) (just checkin)'; + diff --git a/t/004_custom_cache_key.t b/t/004_custom_cache_key.t new file mode 100644 index 0000000..5bceb0c --- /dev/null +++ b/t/004_custom_cache_key.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Exception; +use Scalar::Util; + +{ + package Foo; + use Moose; + use MooseX::Params::Validate; + + sub bar { + my ( $self, $args, $params ) = @_; + $params->{MX_PARAMS_VALIDATE_CACHE_KEY} + = Scalar::Util::refaddr($self); + return validated_hash( $args, %$params ); + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +lives_ok { + $foo->bar( [ baz => 1 ], { baz => { isa => 'Int' } } ); +} +'... successfully applied the parameter validation'; + +throws_ok { + $foo->bar( [ baz => [ 1, 2, 3 ] ], { baz => { isa => 'ArrayRef' } } ); +} qr/\QThe 'baz' parameter/, +'... successfully re-used the parameter validation for this instance'; + +my $foo2 = Foo->new; +isa_ok( $foo2, 'Foo' ); + +lives_ok { + $foo2->bar( [ baz => [ 1, 2, 3 ] ], { baz => { isa => 'ArrayRef' } } ); +} +'... successfully applied the parameter validation'; + +throws_ok { + $foo2->bar( [ baz => 1 ], { baz => { isa => 'Int' } } ); +} qr/\QThe 'baz' parameter/, +'... successfully re-used the parameter validation for this instance'; + +lives_ok { + $foo->bar( [ baz => 1 ], { baz => { isa => 'Int' } } ); +} +'... successfully applied the parameter validation (just checking)'; + diff --git a/t/005_coercion.t b/t/005_coercion.t new file mode 100644 index 0000000..967fdcd --- /dev/null +++ b/t/005_coercion.t @@ -0,0 +1,156 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 15; +use Test::Exception; + +# Note that setting coerce => 1 for the Num type tests that we don't try to do +# coercions for a type which doesn't have any coercions. +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use MooseX::Params::Validate; + + subtype 'Size' => as 'Int' => where { $_ >= 0 }; + + coerce 'Size' => from 'ArrayRef' => via { scalar @{$_} }; + + sub bar { + my $self = shift; + my %params = validated_hash( + \@_, + size1 => { isa => 'Size', coerce => 1 }, + size2 => { isa => 'Size', coerce => 0 }, + number => { isa => 'Num', coerce => 1 }, + ); + [ $params{size1}, $params{size2}, $params{number} ]; + } + + # added to test 'optional' on validated_hash + sub baropt { + my $self = shift; + my %params = validated_hash( + \@_, + size1 => { isa => 'Size', coerce => 1, optional => 1 }, + size2 => { isa => 'Size', coerce => 0, optional => 1 }, + number => { isa => 'Num', coerce => 1, optional => 1 }, + ); + [ $params{size1}, $params{size2}, $params{number} ]; + } + + + sub baz { + my $self = shift; + my ( $size1, $size2, $number ) = validated_list( + \@_, + size1 => { isa => 'Size', coerce => 1 }, + size2 => { isa => 'Size', coerce => 0 }, + number => { isa => 'Num', coerce => 1 }, + ); + [ $size1, $size2, $number ]; + } + + + sub quux { + my $self = shift; + my ( $size1, $size2, $number ) = validated_list( + \@_, + size1 => { isa => 'Size', coerce => 1, optional => 1 }, + size2 => { isa => 'Size', coerce => 0, optional => 1 }, + number => { isa => 'Num', coerce => 1, optional => 1 }, + ); + [ $size1, $size2, $number ]; + } + + sub ran_out { + my $self = shift; + my ( $size1, $size2, $number ) = pos_validated_list( + \@_, + { isa => 'Size', coerce => 1, optional => 1 }, + { isa => 'Size', coerce => 0, optional => 1 }, + { isa => 'Num', coerce => 1, optional => 1 }, + ); + [ $size1, $size2, $number ]; + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +is_deeply( + $foo->bar( size1 => 10, size2 => 20, number => 30 ), + [ 10, 20, 30 ], + 'got the return value right without coercions' +); + +is_deeply( + $foo->bar( size1 => [ 1, 2, 3 ], size2 => 20, number => 30 ), + [ 3, 20, 30 ], + 'got the return value right with coercions for size1' +); + +throws_ok { $foo->bar( size1 => 30, size2 => [ 1, 2, 3 ], number => 30 ) } +qr/\QThe 'size2' parameter/, + '... the size2 param cannot be coerced'; + +throws_ok { $foo->bar( size1 => 30, size2 => 10, number => 'something' ) } +qr/\QThe 'number' parameter/, + '... the number param cannot be coerced because there is no coercion defined for Num'; + +is_deeply( + $foo->baz( size1 => 10, size2 => 20, number => 30 ), + [ 10, 20, 30 ], + 'got the return value right without coercions' +); + +is_deeply( + $foo->baz( size1 => [ 1, 2, 3 ], size2 => 20, number => 30 ), + [ 3, 20, 30 ], + 'got the return value right with coercions for size1' +); + +throws_ok { $foo->baz( size1 => 30, size2 => [ 1, 2, 3 ], number => 30 ) } +qr/\QThe 'size2' parameter/, + '... the size2 param cannot be coerced'; + +throws_ok { $foo->baz( size1 => 30, size2 => 10, number => 'something' ) } +qr/\QThe 'number' parameter/, + '... the number param cannot be coerced'; + +is_deeply( + $foo->baropt( size2 => 4 ), + [ undef, 4, undef ], + '... validated_hash does not try to coerce keys which are not provided' +); + +is_deeply( + $foo->quux( size2 => 4 ), + [ undef, 4, undef ], + '... validated_list does not try to coerce keys which are not provided' +); + +is_deeply( + $foo->ran_out( 1, 2, 3 ), + [ 1, 2, 3 ], + 'got the return value right without coercions' +); + +is_deeply( + $foo->ran_out( [1], 2, 3 ), + [ 1, 2, 3 ], + 'got the return value right with coercion for the first param' +); + +throws_ok { $foo->ran_out( [ 1, 2 ], [ 1, 2 ] ) } +qr/\QParameter #2/, + '... did not attempt to coerce the second parameter'; + + +is_deeply( + $foo->ran_out(), + [ undef, undef, undef ], + 'did not try to coerce non-existent parameters' +); diff --git a/t/006_not_moose.t b/t/006_not_moose.t new file mode 100644 index 0000000..46f64d9 --- /dev/null +++ b/t/006_not_moose.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +eval <<'EOF'; +{ + package Foo; + use MooseX::Params::Validate; +} +EOF + +is( + $@, '', + 'loading MX::Params::Validate in a non-Moose class does not blow up' +); +ok( Foo->can('validated_hash'), 'validated_hash() sub was added to Foo package' ); diff --git a/t/007_deprecated.t b/t/007_deprecated.t new file mode 100644 index 0000000..fb79933 --- /dev/null +++ b/t/007_deprecated.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +{ + package Foo; + + use Moose; + use MooseX::Params::Validate qw( :deprecated ); + +} + +ok( Foo->can('validate'), ':deprecated tag exports validate' ); +ok( Foo->can('validatep'), ':deprecated tag exports validatep' ); diff --git a/t/008_positional.t b/t/008_positional.t new file mode 100644 index 0000000..ac7fe5a --- /dev/null +++ b/t/008_positional.t @@ -0,0 +1,149 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 31; +use Test::Exception; + +{ + package Roles::Blah; + use Moose::Role; + use MooseX::Params::Validate; + + requires 'bar'; + requires 'baz'; + + sub foo { + my ( $self, %params ) = validated_hash( + \@_, + bar => { isa => 'Str', default => 'Moose' }, + ); + return "Horray for $params{bar}!"; + } + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use MooseX::Params::Validate; + + with 'Roles::Blah'; + + sub bar { + my $self = shift; + return [ + pos_validated_list( + \@_, + { isa => 'Foo' }, + { isa => 'ArrayRef | HashRef', optional => 1 }, + { isa => 'ArrayRef[Int]', optional => 1 }, + ) + ]; + } + + sub baz { + my $self = shift; + return [ + pos_validated_list( + \@_, + { + isa => subtype( 'Object' => where { $_->isa('Foo') } ), + optional => 1 + }, + { does => 'Roles::Blah', optional => 1 }, + { + does => role_type('Roles::Blah'), + optional => 1 + }, + ) + ]; + } +} + +my $foo = Foo->new; +isa_ok( $foo, 'Foo' ); + +is( $foo->baz($foo)->[0], $foo, '... first param must be a Foo instance' ); + +throws_ok { $foo->baz(10) } qr/\QParameter #1 ("10")/, + '... the first param in &baz must be a Foo instance'; +throws_ok { $foo->baz('foo') } qr/\QParameter #1 ("foo")/, + '... the first param in &baz must be a Foo instance'; +throws_ok { $foo->baz( [] ) } qr/\QParameter #1/, + '... the first param in &baz must be a Foo instance'; + +is( $foo->baz( $foo, $foo )->[1], $foo, + '... second param must do Roles::Blah' ); + +throws_ok { $foo->baz( $foo, 10 ) } qr/\QParameter #2 ("10")/, + '... the second param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( $foo, 'foo' ) } qr/\QParameter #2 ("foo")/, + '... the second param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( $foo, [] ) } qr/\QParameter #2/, + '... the second param in &baz must be do Roles::Blah'; + +is( $foo->baz( $foo, $foo, $foo )->[2], $foo, + '... third param must do Roles::Blah' ); + +throws_ok { $foo->baz( $foo, $foo, 10 ) } qr/\QParameter #3 ("10")/, + '... the third param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( $foo, $foo, "foo" ) } qr/\QParameter #3 ("foo")/, + '... the third param in &baz must be do Roles::Blah'; +throws_ok { $foo->baz( $foo, $foo, [] ) } qr/\QParameter #3/, + '... the third param in &baz must be do Roles::Blah'; + +throws_ok { $foo->bar } qr/\Q0 parameters were passed/, + '... bar has a required params'; +throws_ok { $foo->bar(10) } qr/\QParameter #1 ("10")/, + '... the first param in &bar must be a Foo instance'; +throws_ok { $foo->bar('foo') } qr/\QParameter #1 ("foo")/, + '... the first param in &bar must be a Foo instance'; +throws_ok { $foo->bar( [] ) } qr/\QParameter #1/, + '... the first param in &bar must be a Foo instance'; +throws_ok { $foo->bar() } qr/\Q0 parameters were passed/, + '... bar has a required first param'; + +is_deeply( + $foo->bar($foo), + [$foo], + '... the first param in &bar got a Foo instance' +); + +is_deeply( + $foo->bar( $foo, [] ), + [ $foo, [] ], + '... the first and second param in &bar got correct args' +); + +is_deeply( + $foo->bar( $foo, {} ), + [ $foo, {} ], + '... the first param and baz param in &bar got correct args' +); + +throws_ok { $foo->bar( $foo, undef ) } qr/\QParameter #2 (undef)/, + '... second param requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( $foo, 10 ) } qr/\QParameter #2 ("10")/, + '... second param requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( $foo, 'Foo' ) } qr/\QParameter #2 ("Foo")/, + '... second param requires a ArrayRef | HashRef'; +throws_ok { $foo->bar( $foo, \( my $var ) ) } qr/\QParameter #2/, + '... second param requires a ArrayRef | HashRef'; + +is_deeply( + $foo->bar( $foo, {}, [ 1, 2, 3 ] ), + [ $foo, {}, [ 1, 2, 3 ] ], + '... the first param in &bar got a Foo instance' +); + +throws_ok { $foo->bar( $foo, {}, undef ) } qr/\QParameter #3 (undef)/, +'... third param a ArrayRef[Int]'; +throws_ok { $foo->bar( $foo, {}, 10 ) } qr/\QParameter #3 ("10")/, +'... third param a ArrayRef[Int]'; +throws_ok { $foo->bar( $foo, {}, 'Foo' ) } qr/\QParameter #3 ("Foo")/, +'... third param a ArrayRef[Int]'; +throws_ok { $foo->bar( $foo, {}, \( my $var ) ) } qr/\QParameter #3/, +'... third param a ArrayRef[Int]'; +throws_ok { $foo->bar( $foo, {}, [qw/one two three/] ) } qr/\QParameter #3/, +'... third param a ArrayRef[Int]'; + diff --git a/t/009_wrapped.t b/t/009_wrapped.t new file mode 100644 index 0000000..6547942 --- /dev/null +++ b/t/009_wrapped.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +{ + package Foo; + use Moose; + use MooseX::Params::Validate; + + sub foo { + my $self = shift; + my %params = validated_hash( + \@_, + foo => { isa => 'Str' }, + ); + return $params{foo}; + } + + around 'foo' => sub { + my $orig = shift; + my $self = shift; + my %p = @_; + + my @args = ( bar => delete $p{bar} ); + + my %params = validated_hash( + \@args, + bar => { isa => 'Str' }, + ); + + $params{bar}, $self->$orig(%p); + }; + + around 'foo' => sub { + my $orig = shift; + my $self = shift; + my %p = @_; + + my @args = ( quux => delete $p{quux} ); + + my %params = validated_hash( + \@args, + quux => { isa => 'Str' }, + ); + + $params{quux}, $self->$orig(%p); + }; +} + +{ + my $foo = Foo->new; + + is_deeply( [ $foo->foo( foo => 1, bar => 2, quux => 3 ) ], + [ 3, 2, 1 ], + 'multiple around wrappers can safely be cached' ); + + is_deeply( [ $foo->foo( foo => 1, bar => 2, quux => 3 ) ], + [ 3, 2, 1 ], + 'multiple around wrappers can safely be cached (2nd time)' ); +} + diff --git a/t/010.overloaded.t b/t/010.overloaded.t new file mode 100644 index 0000000..6fca960 --- /dev/null +++ b/t/010.overloaded.t @@ -0,0 +1,36 @@ + +package Foo; +use Moose; +use MooseX::Params::Validate; +use overload ( + qw{""} => 'to_string', +); + +has 'id' => ( is => 'ro', isa => 'Str', default => '1.10.100' ); + +sub to_string { + my ($self, %args) = validated_hash( \@_, + padded => { isa => 'Bool', optional => 1, default => 0 }, + ); + + # 1.10.100 => 0001.0010.0100 + my $id = $args{ padded } + ? join( '.', map { sprintf( "%04d", $_ ) } split( /\./, $self->id ) ) + : $self->id; + + return $id; +} + +package main; +use Test::More tests => 4; +use strict; +use warnings; + +isa_ok( my $foo = Foo->new(), 'Foo', 'new' ); + +is( $foo->id, '1.10.100', 'id' ); + +is( $foo->to_string, '1.10.100', 'to_string' ); + +is( $foo->to_string( padded => 1 ), '0001.0010.0100', 'to_string( padded => 1 )' ); + diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..defdf05 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; + +all_pod_coverage_ok( { trustme => [ qr/^(?:validatep?|import)$/ ] } );