diff options
Diffstat (limited to 't')
98 files changed, 6566 insertions, 0 deletions
diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..449ef3c --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,70 @@ +do { my $x = { + 'build' => { + 'requires' => { + 'Module::Build' => '0.28' + } + }, + 'configure' => { + 'requires' => { + 'Module::Build' => '0.28' + } + }, + 'develop' => { + 'requires' => { + 'File::Spec' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Perl::Critic' => '1.123', + 'Perl::Tidy' => '20140711', + 'Pod::Coverage::TrustPod' => '0', + 'Readonly' => '1.03', + 'Scalar::Util' => '1.20', + 'Test::CPAN::Changes' => '0.19', + 'Test::EOL' => '0', + 'Test::LeakTrace' => '0.15', + 'Test::More' => '0.96', + 'Test::NoTabs' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Spelling' => '0.12', + 'Test::Synopsis' => '0', + 'Test::Taint' => '0.02' + } + }, + 'runtime' => { + 'requires' => { + 'Attribute::Handlers' => '0.79', + 'Carp' => '0', + 'Exporter' => '0', + 'Module::Implementation' => '0', + 'Scalar::Util' => '1.10', + 'XSLoader' => '0', + 'attributes' => '0', + 'perl' => '5.008001', + 'strict' => '0', + 'vars' => '0', + 'warnings' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'Devel::Peek' => '0', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'File::Temp' => '0', + 'Test::Fatal' => '0', + 'Test::More' => '0.96', + 'Test::Requires' => '0', + 'Tie::Array' => '0', + 'Tie::Hash' => '0', + 'base' => '0', + 'lib' => '0', + 'overload' => '0' + } + } + }; + $x; + }
\ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..d8d15ba --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,183 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META ) { + if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); + } +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/01-validate.t b/t/01-validate.t new file mode 100644 index 0000000..32c2122 --- /dev/null +++ b/t/01-validate.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Standard; +PVTests::Standard::run_tests(); diff --git a/t/02-noop.t b/t/02-noop.t new file mode 100644 index 0000000..fd3bccb --- /dev/null +++ b/t/02-noop.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/03-attribute.t b/t/03-attribute.t new file mode 100644 index 0000000..6bb1b72 --- /dev/null +++ b/t/03-attribute.t @@ -0,0 +1,101 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Attribute::Params::Validate; +use Params::Validate qw(:all); + +sub foo : Validate( c => { type => SCALAR } ) { + my %data = @_; + return $data{c}; +} + +sub bar : Validate( c => { type => SCALAR } ) method { + my $self = shift; + my %data = @_; + return $data{c}; +} + +sub baz : + Validate( foo => { type => ARRAYREF, callbacks => { '5 elements' => sub { @{shift()} == 5 } } } ) +{ + my %data = @_; + return $data{foo}->[0]; +} + +sub buz : ValidatePos( 1 ) { + return $_[0]; +} + +sub quux : ValidatePos( { type => SCALAR }, 1 ) { + return $_[0]; +} + +my $res = eval { foo( c => 1 ) }; +is( + $@, q{}, + "Call foo with a scalar" +); + +is( + $res, 1, + 'Check return value from foo( c => 1 )' +); + +eval { foo( c => [] ) }; + +like( + $@, qr/The 'c' parameter .* was an 'arrayref'/, + 'Check exception thrown from foo( c => [] )' +); + +$res = eval { main->bar( c => 1 ) }; +is( + $@, q{}, + 'Call bar with a scalar' +); + +is( + $res, 1, + 'Check return value from bar( c => 1 )' +); + +eval { baz( foo => [ 1, 2, 3, 4 ] ) }; + +like( + $@, qr/The 'foo' parameter .* did not pass the '5 elements' callback/, + 'Check exception thrown from baz( foo => [1,2,3,4] )' +); + +$res = eval { baz( foo => [ 5, 4, 3, 2, 1 ] ) }; + +is( + $@, q{}, + 'Call baz( foo => [5,4,3,2,1] )' +); + +is( + $res, 5, + 'Check return value from baz( foo => [5,4,3,2,1] )' +); + +eval { buz( [], 1 ) }; + +like( + $@, qr/2 parameters were passed to .* but 1 was expected/, + 'Check exception thrown from quux( [], 1 )' +); + +$res = eval { quux( 1, [] ) }; + +is( + $@, q{}, + 'Call quux' +); + +done_testing(); diff --git a/t/04-defaults.t b/t/04-defaults.t new file mode 100644 index 0000000..49e8259 --- /dev/null +++ b/t/04-defaults.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); diff --git a/t/05-noop_default.t b/t/05-noop_default.t new file mode 100644 index 0000000..cc50768 --- /dev/null +++ b/t/05-noop_default.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); diff --git a/t/06-options.t b/t/06-options.t new file mode 100644 index 0000000..ad167c0 --- /dev/null +++ b/t/06-options.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Params::Validate qw(:all); + +validation_options( stack_skip => 2 ); + +sub foo { + my %p = validate( @_, { bar => 1 } ); +} + +sub bar { foo(@_) } + +sub baz { bar(@_) } + +eval { baz() }; + +like( $@, qr/mandatory.*missing.*call to main::bar/i ); + +validation_options( stack_skip => 3 ); + +eval { baz() }; +like( $@, qr/mandatory.*missing.*call to main::baz/i ); + +validation_options( on_fail => sub { die bless { hash => 'ref' }, 'Dead' } ); + +eval { baz() }; + +my $e = $@; +is( $e->{hash}, 'ref' ); +ok( eval { $e->isa('Dead'); 1; } ); + +done_testing(); diff --git a/t/07-with.t b/t/07-with.t new file mode 100644 index 0000000..85e0658 --- /dev/null +++ b/t/07-with.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::With; +PVTests::With::run_tests(); diff --git a/t/08-noop_with.t b/t/08-noop_with.t new file mode 100644 index 0000000..886254a --- /dev/null +++ b/t/08-noop_with.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::With; +PVTests::With::run_tests(); diff --git a/t/09-regex.t b/t/09-regex.t new file mode 100644 index 0000000..dae8558 --- /dev/null +++ b/t/09-regex.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Regex; +PVTests::Regex::run_tests(); diff --git a/t/10-noop_regex.t b/t/10-noop_regex.t new file mode 100644 index 0000000..89b1148 --- /dev/null +++ b/t/10-noop_regex.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Regex; +PVTests::Regex::run_tests(); diff --git a/t/11-cb.t b/t/11-cb.t new file mode 100644 index 0000000..12e7a0b --- /dev/null +++ b/t/11-cb.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); diff --git a/t/12-noop_cb.t b/t/12-noop_cb.t new file mode 100644 index 0000000..777cf01 --- /dev/null +++ b/t/12-noop_cb.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); diff --git a/t/13-taint.t b/t/13-taint.t new file mode 100644 index 0000000..5d60f1d --- /dev/null +++ b/t/13-taint.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +eval { "$0$^X" && kill 0; 1 }; + +use PVTests::Standard; +PVTests::Standard::run_tests(); diff --git a/t/14-no_validate.t b/t/14-no_validate.t new file mode 100644 index 0000000..07aa215 --- /dev/null +++ b/t/14-no_validate.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use lib './t'; + +use Params::Validate qw(validate); + +use Test::More; +plan tests => $] == 5.006 ? 2 : 3; + +eval { foo() }; +like( $@, qr/parameter 'foo'/ ); + +{ + local $Params::Validate::NO_VALIDATION = 1; + + eval { foo() }; + is( $@, q{} ); +} + +unless ( $] == 5.006 ) { + eval { foo() }; + like( $@, qr/parameter 'foo'/ ); +} + +sub foo { + validate( @_, { foo => 1 } ); +} diff --git a/t/15-case.t b/t/15-case.t new file mode 100644 index 0000000..ff02112 --- /dev/null +++ b/t/15-case.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw(validate validate_with); + +my @testset; + +# Generate test cases ... +BEGIN { + my @lower_case_args = ( foo => 1 ); + my @upper_case_args = ( FOO => 1 ); + my @mixed_case_args = ( FoO => 1 ); + + my %lower_case_spec = ( foo => 1 ); + my %upper_case_spec = ( FOO => 1 ); + my %mixed_case_spec = ( FoO => 1 ); + + my %arglist = ( + lower => \@lower_case_args, + upper => \@upper_case_args, + mixed => \@mixed_case_args + ); + + my %speclist = ( + lower => \%lower_case_spec, + upper => \%upper_case_spec, + mixed => \%mixed_case_spec + ); + + # XXX - make subs such that user gets to see the error message + # when a test fails + my $ok_sub = sub { + if ($@) { + print STDERR $@; + } + !$@; + }; + + my $nok_sub = sub { + my $ok = ( $@ =~ /not listed in the validation options/ ); + unless ($ok) { + print STDERR $@; + } + $ok; + }; + + # generate testcases on the fly (I'm too lazy) + for my $ignore_case (qw( 0 1 )) { + for my $args ( keys %arglist ) { + for my $spec ( keys %speclist ) { + push @testset, { + params => $arglist{$args}, + spec => $speclist{$spec}, + expect => ( + $ignore_case ? $ok_sub + : $args eq $spec ? $ok_sub + : $nok_sub + ), + ignore_case => $ignore_case + }; + } + } + } +} + +plan tests => ( scalar @testset ) * 2; + +{ + + # XXX - "called" will be all messed up, but what the heck + foreach my $case (@testset) { + my %args = eval { + validate_with( + params => $case->{params}, + spec => $case->{spec}, + ignore_case => $case->{ignore_case} + ); + }; + + ok( $case->{expect}->(%args) ); + } + + # XXX - make sure that it works from validation_options() as well + foreach my $case (@testset) { + Params::Validate::validation_options( + ignore_case => $case->{ignore_case} ); + + my %args = eval { + my @args = @{ $case->{params} }; + validate( @args, $case->{spec} ); + }; + + ok( $case->{expect}->(%args) ); + } +} + diff --git a/t/16-normalize.t b/t/16-normalize.t new file mode 100644 index 0000000..1765312 --- /dev/null +++ b/t/16-normalize.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_with); +use Test::More; + +my $ucfirst_normalizer = sub { return ucfirst lc $_[0] }; + +sub sub1 { + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer + ); + + return $args{Paramkey}; +} + +sub sub2 { + + # verify that normalize_callback surpresses ignore_case + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + ignore_case => 1 + ); + + return $args{Paramkey}; +} + +sub sub3 { + + # verify that normalize_callback surpresses strip_leading + my %args = validate_with( + params => \@_, + spec => { -PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + strip_leading => '-' + ); + + return $args{-paramkey}; +} + +sub sub4 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub {undef} + ); +} + +sub sub5 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub { return 'a' }, + ); +} + +ok( eval { sub1( pArAmKeY => 1 ) } ); +ok( eval { sub2( pArAmKeY => 1 ) } ); +ok( eval { sub3( -pArAmKeY => 1 ) } ); + +eval { sub4( foo => 5 ) }; +like( $@, qr/normalize_keys.+a defined value/ ); + +eval { sub5( foo => 5, bar => 5 ) }; +like( $@, qr/normalize_keys.+already exists/ ); + +done_testing(); diff --git a/t/17-callbacks.t b/t/17-callbacks.t new file mode 100644 index 0000000..e06a867 --- /dev/null +++ b/t/17-callbacks.t @@ -0,0 +1,78 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/bigger than bar/ ); + + $p[1] = 3; + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + is( $@, q{} ); +} + +{ + my @p = ( 1, 2, 3 ); + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + like( $@, qr/bigger than \[1\]/ ); + + $p[0] = 5; + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + is( $@, q{} ); +} + +done_testing(); diff --git a/t/18-depends.t b/t/18-depends.t new file mode 100644 index 0000000..a94d3bf --- /dev/null +++ b/t/18-depends.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +{ + my %spec = ( + foo => { optional => 1, depends => 'bar' }, + bar => { optional => 1 }, + ); + + my @args = ( bar => 1 ); + + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(1): no depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(2): with depends, positive" ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() single depends(3.a): with depends, negative" ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'bar', which was not given), + "validate() single depends(3.b): check error string" + ); +} + +{ + my %spec = ( + foo => { optional => 1, depends => [qw(bar baz)] }, + bar => { optional => 1 }, + baz => { optional => 1 }, + ); + + # positive, no depends (single, multiple) + my @args = ( bar => 1 ); + eval { validate( @args, \%spec ) }; + is( + $@, q{}, + "validate() multiple depends(1): no depends, single arg, positive" + ); + + @args = ( bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( + $@, q{}, + "validate() multiple depends(2): no depends, multiple arg, positive" + ); + + @args = ( foo => 1, bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() multiple depends(3): with depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(4.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'baz', which was not given), + "validate() multiple depends (4.b): check error string" + ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(5.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter '(bar|baz)', which was not given), + "validate() multiple depends (5.b): check error string" + ); +} + +{ + + # bad depends + my %spec = ( + foo => { optional => 1, depends => { 'bar' => 1 } }, + bar => { optional => 1 }, + ); + + my @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() bad depends spec (1.a): depends is a hashref" ); + like( + $@, + qr(^Arguments to 'depends' must be a scalar or arrayref), + "validate() bad depends spec (1.a): check error string" + ); +} + +{ + my @spec = ( { optional => 1 } ); + + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + is( $@, q{}, "validate_pos() no depends, positive" ); +} + +{ + my @spec = ( { optional => 1, depends => 2 }, { optional => 1 } ); + + my @args = qw(1 1); + eval { validate_pos( @args, @spec ) }; + + is( + $@, q{}, + "validate_pos() single depends (1): with depends, positive" + ); +} + +{ + my @spec = ( + { optional => 1, depends => 4 }, + { optional => 1 }, { optional => 1 }, + { optional => 1 } + ); + + my @args = qw(1 0); + eval { validate_pos( @args, @spec ) }; + + ok( $@, "validate_pos() single depends (2.a): with depends, negative" ); + like( + $@, + qr(^Parameter #1 depends on parameter #4, which was not given), + "validate_pos() single depends (2.b): check error" + ); +} + +{ + my @spec = ( + { optional => 1, depends => [ 2, 3 ] }, + { optional => 1 }, + 0 + ); + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + ok( + $@, + "validate_pos() multiple depends (1.a): with depends, bad args negative" + ); + like( + $@, + qr{^Arguments to 'depends' for validate_pos\(\) must be a scalar}, + "validate_pos() multiple depends (1.b): check error" + ); +} + +done_testing(); diff --git a/t/19-untaint.t b/t/19-untaint.t new file mode 100644 index 0000000..fb3f08c --- /dev/null +++ b/t/19-untaint.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl -T + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + untaint => 1, + }, + }, + ); + + untainted_ok( $p{value}, 'value is untainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + untaint => 1, + }, + ); + + untainted_ok( $new_value, 'value is untainted after validation' ); +} + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + }, + }, + ); + + tainted_ok( $p{value}, 'value is still tainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + }, + ); + + tainted_ok( $new_value, 'value is still tainted after validation' ); +} + +done_testing(); diff --git a/t/21-can.t b/t/21-can.t new file mode 100644 index 0000000..5230c44 --- /dev/null +++ b/t/21-can.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassCan' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'baz' } }, ); }; + + like( $@, qr/does not have the method: 'baz'/ ); +} + +{ + my $object = bless {}, 'ClassCan'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my $object = bless {}, 'SubClass'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass object->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'unblessed ref ->can' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'number can' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'string can' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'undef can' ); +} + +done_testing(); + +package ClassCan; + +sub can { + return 1 if $_[1] eq 'cancan'; + return 0; +} + +sub thingy {1} + +package SubClass; + +use base 'ClassCan'; diff --git a/t/22-overload-can-bug.t b/t/22-overload-can-bug.t new file mode 100644 index 0000000..44d81e8 --- /dev/null +++ b/t/22-overload-can-bug.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + package Overloaded; + + use overload 'bool' => sub {0}; + + sub new { bless {} } + + sub foo {1} +} + +my $ovl = Overloaded->new; + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { isa => 'Overloaded' } } ); + }; + + is( $@, q{}, 'overloaded object->isa' ); +} + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { can => 'foo' } } ); + }; + + is( $@, q{}, 'overloaded object->foo' ); +} + +done_testing(); diff --git a/t/23-readonly.t b/t/23-readonly.t new file mode 100644 index 0000000..a8b7ced --- /dev/null +++ b/t/23-readonly.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::Requires { + Readonly => '1.03', + 'Scalar::Util' => '1.20', +}; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +plan skip_all => 'These tests fail with Readonly 1.50 for some reason' + if Readonly::->VERSION() =~ /^v?1.5/; + +{ + Readonly my $spec => { foo => 1 }; + my @p = ( foo => 'hello' ); + + eval { validate( @p, $spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my $spec => { type => SCALAR }; + my @p = 'hello'; + + eval { validate_pos( @p, $spec ) }; + is( $@, q{}, 'validate_pos() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my %spec => ( foo => { type => SCALAR } ); + my @p = ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hash' ); +} + +done_testing(); diff --git a/t/24-tied.t b/t/24-tied.t new file mode 100644 index 0000000..85b6825 --- /dev/null +++ b/t/24-tied.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + package Tie::SimpleArray; + use Tie::Array; + use base 'Tie::StdArray'; +} + +{ + + package Tie::SimpleHash; + use Tie::Hash; + use base 'Tie::StdHash'; +} + +{ + tie my @p, 'Tie::SimpleArray'; + + my %spec = ( foo => 1 ); + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and tied hashref spec' + ); +} + +{ + tie my @p, 'Tie::SimpleArray'; + my %spec; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and tied hashref spec' + ); +} + +done_testing(); diff --git a/t/25-undef-regex.t b/t/25-undef-regex.t new file mode 100644 index 0000000..64fe996 --- /dev/null +++ b/t/25-undef-regex.t @@ -0,0 +1,17 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @w; + local $SIG{__WARN__} = sub { push @w, @_ }; + + my @p = ( foo => undef ); + eval { validate( @p, { foo => { regex => qr/^bar/ } } ) }; + ok( $@, 'validation failed' ); + ok( !@w, 'no warnings' ); +} + +done_testing(); diff --git a/t/26-isa.t b/t/26-isa.t new file mode 100644 index 0000000..cd38c06 --- /dev/null +++ b/t/26-isa.t @@ -0,0 +1,89 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassISA' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'no error checking if ClassISA->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + like( $@, qr/was not a 'FooBar'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => bless {}, 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'unblessed ref ->isa' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'number isa' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'string isa' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'undef isa' ); +} + +done_testing(); + +package ClassISA; + +sub isa { + return 1 if $_[1] eq 'FooBar'; + return $_[0]->SUPER::isa( $_[1] ); +} + +sub thingy {1} + +package SubClass; + +use base 'ClassISA'; diff --git a/t/27-string-as-type.t b/t/27-string-as-type.t new file mode 100644 index 0000000..45795cd --- /dev/null +++ b/t/27-string-as-type.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => 'SCALAR' } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is a string - SCALAR/ + ); +} + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => undef } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is undef/ + ); + +} + +done_testing(); diff --git a/t/28-readonly-return.t b/t/28-readonly-return.t new file mode 100644 index 0000000..37fc042 --- /dev/null +++ b/t/28-readonly-return.t @@ -0,0 +1,93 @@ +use strict; +use warnings; +use Test::More; + +use Devel::Peek qw( SvREFCNT ); +use File::Temp qw( tempfile ); +use Params::Validate qw( validate SCALAR HANDLE ); + +{ + my $fh = tempfile(); + my @p = ( + foo => 1, + bar => $fh, + ); + + my $ref = val1(@p); + + eval { $ref->{foo} = 2 }; + ok( !$@, 'returned hashref values are not read only' ); + is( $ref->{foo}, 2, 'double check that setting value worked' ); + is( $fh, $ref->{bar}, 'filehandle is not copied during validation' ); +} + +{ + + package ScopeTest; + + my $live = 0; + + sub new { $live++; bless {}, shift } + sub DESTROY { $live-- } + + sub Live {$live} +} + +{ + my @p = ( foo => ScopeTest->new() ); + + is( + ScopeTest->Live(), 1, + 'one live object' + ); + + my $ref = val2(@p); + + isa_ok( $ref->{foo}, 'ScopeTest' ); + + @p = (); + + is( + ScopeTest->Live(), 1, + 'still one live object' + ); + + ok( + defined $ref->{foo}, + 'foo key stays in scope after original version goes out of scope' + ); + is( + SvREFCNT( $ref->{foo} ), 1, + 'ref count for reference is 1' + ); + + undef $ref->{foo}; + + is( + ScopeTest->Live(), 0, + 'no live objects' + ); +} + +sub val1 { + my $ref = validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HANDLE, optional => 1 }, + }, + ); + + return $ref; +} + +sub val2 { + my $ref = validate( + @_, { + foo => 1, + }, + ); + + return $ref; +} + +done_testing(); diff --git a/t/29-taint-mode.t b/t/29-taint-mode.t new file mode 100644 index 0000000..9db983f --- /dev/null +++ b/t/29-taint-mode.t @@ -0,0 +1,53 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Test::Fatal; +use Test::More; + +use Params::Validate qw( validate validate_pos ARRAYREF ); + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +sub test1 { + my $def = $0; + tainted_ok( $def, 'make sure $def is tainted' ); + + # The spec is irrelevant, all that matters is that there's a + # tainted scalar as the default + my %p = validate( @_, { foo => { default => $def } } ); +} + +{ + is( + exception { test1() }, + undef, + 'no taint error when we validate with tainted default value' + ); +} + +sub test2 { + return validate_pos( @_, { regex => qr/^b/ } ); +} + +SKIP: +{ + skip 'This test only passes on Perl 5.14+', 1 + unless $] >= 5.014; + + my @p = 'cat'; + taint(@p); + + like( + exception { test2(@p) }, + qr/\QParameter #1 ("cat") to main::test2 did not pass regex check/, + 'no taint error when we validate with tainted value values being validated' + ); +} + +done_testing(); diff --git a/t/30-hashref-alteration.t b/t/30-hashref-alteration.t new file mode 100644 index 0000000..116353f --- /dev/null +++ b/t/30-hashref-alteration.t @@ -0,0 +1,51 @@ +use strict; +use warnings; +use Test::More; + +use Params::Validate qw( validate SCALAR ); + +{ + my $p = { foo => 1 }; + + val($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val' + ); + + val2($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val, even with defaults being supplied' + ); +} + +sub val { + validate( + @_, { + foo => { optional => 1 }, + bar => { optional => 1 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +sub val2 { + validate( + @_, { + foo => { optional => 1 }, + bar => { default => 42 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +done_testing(); diff --git a/t/31-incorrect-spelling.t b/t/31-incorrect-spelling.t new file mode 100644 index 0000000..66cad86 --- /dev/null +++ b/t/31-incorrect-spelling.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw( validate validate_pos SCALAR ); + +plan skip_all => 'Spec validation is disabled for now'; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbucks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + + eval { + validate( + @p, { + foo => { + hype => SCALAR, + callbacks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + eval { + validate( + @p, { + foo => { + type => SCALAR, + regexp => qr/^\d+$/, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); +} + +done_testing(); diff --git a/t/32-regex-as-value.t b/t/32-regex-as-value.t new file mode 100644 index 0000000..bbd0640 --- /dev/null +++ b/t/32-regex-as-value.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR SCALARREF ); + +use Test::More; +use Test::Fatal; + +is( + exception { v( foo => qr/foo/ ) }, + undef, + 'no exception with regex object' +); + +is( + exception { v( foo => 'foo' ) }, + undef, + 'no exception with plain scalar' +); + +my $foo = 'foo'; +is( + exception { v( foo => \$foo ) }, + undef, + 'no exception with scalar ref' +); + +done_testing(); + +sub v { + validate( + @_, { + foo => { type => SCALAR | SCALARREF }, + }, + ); + return; +} diff --git a/t/33-keep-errsv.t b/t/33-keep-errsv.t new file mode 100644 index 0000000..8c0324e --- /dev/null +++ b/t/33-keep-errsv.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR ); + +use Test::More; + +{ + $@ = 'foo'; + v( bar => 42 ); + + is( + $@, + 'foo', + 'calling validate() does not clobber' + ); +} + +done_testing(); + +sub v { + validate( @_, { bar => { type => SCALAR } } ); +} diff --git a/t/34-recursive-validation.t b/t/34-recursive-validation.t new file mode 100644 index 0000000..fbf26e6 --- /dev/null +++ b/t/34-recursive-validation.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate SCALAR ); + + Params::Validate::validation_options( allow_extra => 1 ); + + sub test_foo { + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + print "test foo\n"; + } +} + +{ + package Bar; + + use Params::Validate qw( validate SCALAR ); + Params::Validate::validation_options( allow_extra => 0 ); + + sub test_bar { + + # catch die signal + local $SIG{__DIE__} = sub { + + # we died from within Params::Validate (because of wrong_Arg) we + # call Foo::test_foo with OK args, but it'll die, because + # Params::Validate::PP::options is still set to the options of the + # Bar package, and so it won't retreive the one from Foo. + Foo::test_foo( arg1 => 1, extra_arg => 2 ); + }; + + # this will die because the arg received is 'wrong_arg' + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + } +} + +{ + # This bug only manifests with the pure Perl code because of its use of local + # to remember the per-package options. + local $TODO = 'Not sure how to fix this one'; + unlike( + exception { Bar::test_bar( bad_arg => 2 ) }, + qr/was passed in the call to Foo::test_foo/, + 'no exception from Foo::test_foo when when calling validate() from within a __DIE__ handler' + ); +} + +done_testing(); diff --git a/t/35-default-xs-bug.t b/t/35-default-xs-bug.t new file mode 100644 index 0000000..7867db5 --- /dev/null +++ b/t/35-default-xs-bug.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More 0.88; + +use Params::Validate qw( :all ); + +default_test(); + +done_testing(); + +sub default_test { + my ( $first, $second ) = validate_pos( + @_, + { type => SCALAR, optional => 1 }, + { type => SCALAR, optional => 1, default => 'must be second one' }, + ); + + is( $first, undef, '01 no default for first' ); + is( $second, 'must be second one', '01 default for second' ); +} diff --git a/t/36-large-arrays.t b/t/36-large-arrays.t new file mode 100644 index 0000000..7014e0d --- /dev/null +++ b/t/36-large-arrays.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate ARRAYREF ); + + sub v1 { + my %p = validate( + @_, { + array => { + callbacks => { + 'checking array contents' => sub { + for my $x ( @{ $_[0] } ) { + return 0 unless defined $x && !ref $x; + } + return 1; + }, + } + } + } + ); + return $p{array}; + } +} + +{ + for my $size ( 100, 1_000, 100_000 ) { + my @array = ('x') x $size; + is_deeply( + Foo::v1( array => \@array ), + \@array, + "validate() handles $size element array correctly" + ); + } +} + +done_testing(); diff --git a/t/37-exports.t b/t/37-exports.t new file mode 100644 index 0000000..4715090 --- /dev/null +++ b/t/37-exports.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Params::Validate (); + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +my @subs = qw( + validate + validate_pos + validation_options + validate_with +); + +is_deeply( + [ sort @Params::Validate::EXPORT_OK ], + [ sort @types, @subs, 'set_options' ], + '@EXPORT_OK' +); + +is_deeply( + [ sort keys %Params::Validate::EXPORT_TAGS ], + [qw( all types )], + 'keys %EXPORT_TAGS' +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{all} } ], + [ sort @types, @subs ], + '$EXPORT_TAGS{all}', +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{types} } ], + [ sort @types ], + '$EXPORT_TAGS{types}', +); + +done_testing(); diff --git a/t/38-callback-message.t b/t/38-callback-message.t new file mode 100644 index 0000000..c330d58 --- /dev/null +++ b/t/38-callback-message.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use Test::More; +use Params::Validate qw( validate ); + +{ + my $e = _test_args( + pos_int => 42, + string => 'foo', + ); + is( + $e, + q{}, + 'no error with good args' + ); +} + +{ + my $e = _test_args( + pos_int => 42, + string => [], + ); + like( + $e, + qr/The 'string' parameter \("ARRAY\(.+\)"\) to main::validate1 did not pass the 'string' callback: ARRAY\(.+\) is not a string/, + 'got error for bad string' + ); +} + +{ + my $e = _test_args( + pos_int => 0, + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("0") to main::validate1 did not pass the 'pos_int' callback: 0 is not a positive integer/, + 'got error for bad pos int (0)' + ); +} + +{ + my $e = _test_args( + pos_int => 'bar', + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("bar") to main::validate1 did not pass the 'pos_int' callback: bar is not a positive integer/, + 'got error for bad pos int (bar)' + ); +} + +{ + my $e = do { + local $@; + eval { validate2( string => [] ); }; + $@; + }; + + is_deeply( + $e, + { error => 'not a string' }, + 'ref thrown by callback is preserved, not stringified' + ); +} + +sub _test_args { + local $@; + eval { validate1(@_) }; + return $@; +} + +sub validate1 { + validate( + @_, { + pos_int => { + callbacks => { + pos_int => sub { + $_[0] =~ /^[1-9][0-9]*$/ + or die "$_[0] is not a positive integer\n"; + }, + }, + }, + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die "$_[0] is not a string\n"; + }, + }, + }, + } + ); +} + +sub validate2 { + validate( + @_, { + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die { error => 'not a string' }; + }, + }, + }, + } + ); +} + +done_testing(); diff --git a/t/author-00-compile.t b/t/author-00-compile.t new file mode 100644 index 0000000..e2a109f --- /dev/null +++ b/t/author-00-compile.t @@ -0,0 +1,68 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.053 + +use Test::More; + +plan tests => 8; + +my @module_files = ( + 'Attribute/Params/Validate.pm', + 'Params/Validate.pm', + 'Params/Validate/Constants.pm', + 'Params/Validate/PP.pm', + 'Params/Validate/XS.pm', + 'Params/ValidatePP.pm', + 'Params/ValidateXS.pm' +); + + + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); + + diff --git a/t/author-eol.t b/t/author-eol.t new file mode 100644 index 0000000..a7eade1 --- /dev/null +++ b/t/author-eol.t @@ -0,0 +1,126 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.18 + +use Test::More 0.88; +use Test::EOL; + +my @files = ( + 'lib/Attribute/Params/Validate.pm', + 'lib/Params/Validate.pm', + 'lib/Params/Validate/Constants.pm', + 'lib/Params/Validate/PP.pm', + 'lib/Params/Validate/XS.pm', + 'lib/Params/ValidatePP.pm', + 'lib/Params/ValidateXS.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-validate.t', + 't/02-noop.t', + 't/03-attribute.t', + 't/04-defaults.t', + 't/05-noop_default.t', + 't/06-options.t', + 't/07-with.t', + 't/08-noop_with.t', + 't/09-regex.t', + 't/10-noop_regex.t', + 't/11-cb.t', + 't/12-noop_cb.t', + 't/13-taint.t', + 't/14-no_validate.t', + 't/15-case.t', + 't/16-normalize.t', + 't/17-callbacks.t', + 't/18-depends.t', + 't/19-untaint.t', + 't/21-can.t', + 't/22-overload-can-bug.t', + 't/23-readonly.t', + 't/24-tied.t', + 't/25-undef-regex.t', + 't/26-isa.t', + 't/27-string-as-type.t', + 't/28-readonly-return.t', + 't/29-taint-mode.t', + 't/30-hashref-alteration.t', + 't/31-incorrect-spelling.t', + 't/32-regex-as-value.t', + 't/33-keep-errsv.t', + 't/34-recursive-validation.t', + 't/35-default-xs-bug.t', + 't/36-large-arrays.t', + 't/37-exports.t', + 't/38-callback-message.t', + 't/author-00-compile.t', + 't/author-eol.t', + 't/author-no-tabs.t', + 't/author-pod-spell.t', + 't/lib/PVTests.pm', + 't/lib/PVTests/Callbacks.pm', + 't/lib/PVTests/Defaults.pm', + 't/lib/PVTests/Regex.pm', + 't/lib/PVTests/Standard.pm', + 't/lib/PVTests/With.pm', + 't/release-cpan-changes.t', + 't/release-memory-leak.t', + 't/release-pod-coverage.t', + 't/release-pod-linkcheck.t', + 't/release-pod-no404s.t', + 't/release-pod-syntax.t', + 't/release-portability.t', + 't/release-pp-01-validate.t', + 't/release-pp-02-noop.t', + 't/release-pp-03-attribute.t', + 't/release-pp-04-defaults.t', + 't/release-pp-05-noop_default.t', + 't/release-pp-06-options.t', + 't/release-pp-07-with.t', + 't/release-pp-08-noop_with.t', + 't/release-pp-09-regex.t', + 't/release-pp-10-noop_regex.t', + 't/release-pp-11-cb.t', + 't/release-pp-12-noop_cb.t', + 't/release-pp-13-taint.t', + 't/release-pp-14-no_validate.t', + 't/release-pp-15-case.t', + 't/release-pp-16-normalize.t', + 't/release-pp-17-callbacks.t', + 't/release-pp-18-depends.t', + 't/release-pp-19-untaint.t', + 't/release-pp-21-can.t', + 't/release-pp-22-overload-can-bug.t', + 't/release-pp-23-readonly.t', + 't/release-pp-24-tied.t', + 't/release-pp-25-undef-regex.t', + 't/release-pp-26-isa.t', + 't/release-pp-27-string-as-type.t', + 't/release-pp-28-readonly-return.t', + 't/release-pp-29-taint-mode.t', + 't/release-pp-30-hashref-alteration.t', + 't/release-pp-31-incorrect-spelling.t', + 't/release-pp-32-regex-as-value.t', + 't/release-pp-33-keep-errsv.t', + 't/release-pp-34-recursive-validation.t', + 't/release-pp-35-default-xs-bug.t', + 't/release-pp-36-large-arrays.t', + 't/release-pp-37-exports.t', + 't/release-pp-38-callback-message.t', + 't/release-pp-is-loaded.t', + 't/release-synopsis.t', + 't/release-xs-is-loaded.t', + 't/release-xs-segfault.t', + 't/release-xs-stack-realloc.t' +); + +eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files; +done_testing; diff --git a/t/author-no-tabs.t b/t/author-no-tabs.t new file mode 100644 index 0000000..dfaba7c --- /dev/null +++ b/t/author-no-tabs.t @@ -0,0 +1,126 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'lib/Attribute/Params/Validate.pm', + 'lib/Params/Validate.pm', + 'lib/Params/Validate/Constants.pm', + 'lib/Params/Validate/PP.pm', + 'lib/Params/Validate/XS.pm', + 'lib/Params/ValidatePP.pm', + 'lib/Params/ValidateXS.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-validate.t', + 't/02-noop.t', + 't/03-attribute.t', + 't/04-defaults.t', + 't/05-noop_default.t', + 't/06-options.t', + 't/07-with.t', + 't/08-noop_with.t', + 't/09-regex.t', + 't/10-noop_regex.t', + 't/11-cb.t', + 't/12-noop_cb.t', + 't/13-taint.t', + 't/14-no_validate.t', + 't/15-case.t', + 't/16-normalize.t', + 't/17-callbacks.t', + 't/18-depends.t', + 't/19-untaint.t', + 't/21-can.t', + 't/22-overload-can-bug.t', + 't/23-readonly.t', + 't/24-tied.t', + 't/25-undef-regex.t', + 't/26-isa.t', + 't/27-string-as-type.t', + 't/28-readonly-return.t', + 't/29-taint-mode.t', + 't/30-hashref-alteration.t', + 't/31-incorrect-spelling.t', + 't/32-regex-as-value.t', + 't/33-keep-errsv.t', + 't/34-recursive-validation.t', + 't/35-default-xs-bug.t', + 't/36-large-arrays.t', + 't/37-exports.t', + 't/38-callback-message.t', + 't/author-00-compile.t', + 't/author-eol.t', + 't/author-no-tabs.t', + 't/author-pod-spell.t', + 't/lib/PVTests.pm', + 't/lib/PVTests/Callbacks.pm', + 't/lib/PVTests/Defaults.pm', + 't/lib/PVTests/Regex.pm', + 't/lib/PVTests/Standard.pm', + 't/lib/PVTests/With.pm', + 't/release-cpan-changes.t', + 't/release-memory-leak.t', + 't/release-pod-coverage.t', + 't/release-pod-linkcheck.t', + 't/release-pod-no404s.t', + 't/release-pod-syntax.t', + 't/release-portability.t', + 't/release-pp-01-validate.t', + 't/release-pp-02-noop.t', + 't/release-pp-03-attribute.t', + 't/release-pp-04-defaults.t', + 't/release-pp-05-noop_default.t', + 't/release-pp-06-options.t', + 't/release-pp-07-with.t', + 't/release-pp-08-noop_with.t', + 't/release-pp-09-regex.t', + 't/release-pp-10-noop_regex.t', + 't/release-pp-11-cb.t', + 't/release-pp-12-noop_cb.t', + 't/release-pp-13-taint.t', + 't/release-pp-14-no_validate.t', + 't/release-pp-15-case.t', + 't/release-pp-16-normalize.t', + 't/release-pp-17-callbacks.t', + 't/release-pp-18-depends.t', + 't/release-pp-19-untaint.t', + 't/release-pp-21-can.t', + 't/release-pp-22-overload-can-bug.t', + 't/release-pp-23-readonly.t', + 't/release-pp-24-tied.t', + 't/release-pp-25-undef-regex.t', + 't/release-pp-26-isa.t', + 't/release-pp-27-string-as-type.t', + 't/release-pp-28-readonly-return.t', + 't/release-pp-29-taint-mode.t', + 't/release-pp-30-hashref-alteration.t', + 't/release-pp-31-incorrect-spelling.t', + 't/release-pp-32-regex-as-value.t', + 't/release-pp-33-keep-errsv.t', + 't/release-pp-34-recursive-validation.t', + 't/release-pp-35-default-xs-bug.t', + 't/release-pp-36-large-arrays.t', + 't/release-pp-37-exports.t', + 't/release-pp-38-callback-message.t', + 't/release-pp-is-loaded.t', + 't/release-synopsis.t', + 't/release-xs-is-loaded.t', + 't/release-xs-segfault.t', + 't/release-xs-stack-realloc.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/t/author-pod-spell.t b/t/author-pod-spell.t new file mode 100644 index 0000000..f9c5646 --- /dev/null +++ b/t/author-pod-spell.t @@ -0,0 +1,64 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; +use Test::More; + +# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.006009 +use Test::Spelling 0.12; +use Pod::Wordlist; + + +add_stopwords(<DATA>); +all_pod_files_spelling_ok( qw( bin lib ) ); +__DATA__ +DROLSKY +DROLSKY's +Rolsky +Rolsky's +API +CPAN +GLOBREF +OO +PayPal +SCALARREF +ValidatePos +baz +onwards +pre +runtime +Dave +autarch +Ilya +Martynov +ilya +and +Ivan +Bessarabov +ivan +Mash +jmash +Noel +Maddy +zhtwnpanta +Olivier +Mengué +dolmen +Vincent +Pit +perl +lib +Attribute +Params +Validate +Constants +PP +XS +ValidatePP +ValidateXS diff --git a/t/lib/PVTests.pm b/t/lib/PVTests.pm new file mode 100644 index 0000000..0d1b54b --- /dev/null +++ b/t/lib/PVTests.pm @@ -0,0 +1,8 @@ +package PVTests; + +use strict; +use warnings; + +use Test::More; + +1; diff --git a/t/lib/PVTests/Callbacks.pm b/t/lib/PVTests/Callbacks.pm new file mode 100644 index 0000000..c45b4fb --- /dev/null +++ b/t/lib/PVTests/Callbacks.pm @@ -0,0 +1,82 @@ +package PVTests::Callbacks; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + my %allowed = ( foo => 1, baz => 1 ); + eval { + my @a = ( foo => 'foo' ); + validate( + @a, { + foo => { + callbacks => { + is_allowed => sub { $allowed{ lc $_[0] } } + }, + } + } + ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'aksjgakl' ); + + validate( + @a, { + foo => { + callbacks => { + is_allowed => sub { $allowed{ lc $_[0] } } + }, + } + } + ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/is_allowed/ ); + } + + # duplicates code from Lingua::ZH::CCDICT that revealad bug fixed in + # 0.56. + eval { Foo->new( storage => 'InMemory', file => 'something' ); }; + is( $@, q{} ); + + done_testing(); +} + +package Foo; + +use Params::Validate qw(:all); + +my %storage = map { lc $_ => $_ } (qw( InMemory XML BerkeleyDB )); + +sub new { + my $class = shift; + + local $^W = 1; + + my %p = validate_with( + params => \@_, + spec => { + storage => { + callbacks => { + 'is a valid storage type' => sub { $storage{ lc $_[0] } } + }, + }, + }, + allow_extra => 1, + ); + + return 1; +} + +1; diff --git a/t/lib/PVTests/Defaults.pm b/t/lib/PVTests/Defaults.pm new file mode 100644 index 0000000..5d22099 --- /dev/null +++ b/t/lib/PVTests/Defaults.pm @@ -0,0 +1,166 @@ +package PVTests::Defaults; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + { + my %def = eval { foo() }; + + is( + $@, q{}, + 'No error calling foo()' + ); + + is( + $def{a}, 1, + q|Parameter 'a' was not altered| + ); + + is( + $def{b}, 2, + q|Parameter 'b' was not altered| + ); + + is( + $def{c}, 42, + q|Correct default assigned for parameter 'c'| + ); + + is( + $def{d}, 0, + q|Correct default assigned for parameter 'd'| + ); + } + + { + my $def = eval { foo() }; + + is( + $@, q{}, + 'No error calling foo()' + ); + + is( + $def->{a}, 1, + q|Parameter 'a' was not altered| + ); + + is( + $def->{b}, 2, + q|Parameter 'b' was not altered| + ); + + is( + $def->{c}, 42, + q|Correct default assigned for parameter 'c'| + ); + + is( + $def->{d}, 0, + q|Correct default assigned for parameter 'd'| + ); + } + + { + my @def = eval { bar() }; + + is( + $@, q{}, + 'No error calling bar()' + ); + + is( + $def[0], 1, + '1st parameter was not altered' + ); + + is( + $def[1], 2, + '2nd parameter was not altered' + ); + + is( + $def[2], 42, + 'Correct default assigned for 3rd parameter' + ); + + is( + $def[3], 0, + 'Correct default assigned for 4th parameter' + ); + } + + { + my $def = eval { bar() }; + + is( + $@, q{}, + 'No error calling bar()' + ); + + is( + $def->[0], 1, + '1st parameter was not altered' + ); + + is( + $def->[1], 2, + '2nd parameter was not altered' + ); + + is( + $def->[2], 42, + 'Correct default assigned for 3rd parameter' + ); + + is( + $def->[3], 0, + 'Correct default assigned for 4th parameter' + ); + } + + { + my $spec = { foobar => { default => [] } }; + my $test1 = validate_with( params => [], spec => $spec ); + $test1->{foobar} = ['x']; + + my $test2 = validate_with( params => [], spec => $spec ); + $test2->{foobar} = ['y']; + + is( + $test1->{foobar}[0], 'x', + 'defaults pointing to a reference return a copy of that reference' + ); + } + + done_testing(); +} + +sub foo { + my @params = ( a => 1, b => 2 ); + return validate( + @params, { + a => 1, + b => { default => 99 }, + c => { optional => 1, default => 42 }, + d => { default => 0 }, + } + ); +} + +sub bar { + my @params = ( 1, 2 ); + + return validate_pos( + @params, 1, { default => 99 }, { default => 42 }, + { default => 0 } + ); +} + +1; diff --git a/t/lib/PVTests/Regex.pm b/t/lib/PVTests/Regex.pm new file mode 100644 index 0000000..3075427 --- /dev/null +++ b/t/lib/PVTests/Regex.pm @@ -0,0 +1,85 @@ +package PVTests::Regex; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + plan tests => 7; + + eval { + my @a = ( foo => 'bar' ); + validate( @a, { foo => { regex => '^bar$' } } ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'bar' ); + validate( @a, { foo => { regex => qr/^bar$/ } } ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'baz' ); + validate( @a, { foo => { regex => '^bar$' } } ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'foo'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz' ); + validate( @a, { foo => { regex => qr/^bar$/ } } ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'foo'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz', bar => 'quux' ); + validate( + @a, { + foo => { regex => qr/^baz$/ }, + bar => { regex => 'uqqx' }, + } + ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'bar'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz', bar => 'quux' ); + validate( + @a, { + foo => { regex => qr/^baz$/ }, + bar => { regex => qr/^(?:not this|quux)$/ }, + } + ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => undef ); + validate( @a, { foo => { regex => qr/^$|^bubba$/ } } ); + }; + is( $@, q{} ); +} + +1; diff --git a/t/lib/PVTests/Standard.pm b/t/lib/PVTests/Standard.pm new file mode 100644 index 0000000..0c82ed4 --- /dev/null +++ b/t/lib/PVTests/Standard.pm @@ -0,0 +1,956 @@ +package PVTests::Standard; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More 0.88; + +my $String = 'foo'; + +my ( $v1, $v2, $v3, $v4 ); +my $Foo = bless \$v1, 'Foo'; +my $Bar = bless \$v2, 'Bar'; +my $Baz = bless \$v3, 'Baz'; +my $Quux = bless \$v4, 'Quux'; + +my @Tests = ( + { + sub => 'sub1', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub1', + p => [ foo => 'a' ], + expect => qr|^Mandatory parameter 'bar' missing|, + }, + + { + sub => 'sub1', + p => [], + expect => qr|^Mandatory parameters .* missing|, + }, + + { + sub => 'sub1', + p => [ foo => 'a', bar => 'b', baz => 'c' ], + expect => qr|^The following parameter .* baz|, + }, + + { + sub => 'sub2', + p => [ foo => 'a', bar => 'b', baz => 'c' ], + expect => q{}, + }, + + { + sub => 'sub2', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub2a', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub2a', + p => [ foo => 'a' ], + expect => q{}, + }, + + # simple types + { + sub => 'sub3', + p => [ + foo => 'a', + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => {qw( a b c d )}, + ], + expect => q{}, + }, + + { + sub => 'sub3', + p => [ + foo => ['a'], + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => {qw( a b c d )}, + ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was an 'arrayref'.* types: scalar|, + }, + + { + sub => 'sub3', + p => [ + foo => 'foobar', + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => [qw( a b c d )], + ], + expect => + qr|^The 'brax' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was an 'arrayref'.* types: scalar hash|, + }, + + { + sub => 'sub3', + p => [ + foo => 'foobar', + bar => { 1, 2, 3, 4 }, + baz => { a => 1 }, + quux => 'yadda', + brax => 'a', + ], + expect => + qr|^The 'bar' parameter \("HASH\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was a 'hashref'.* types: arrayref|, + }, + + # more unusual types + { + sub => 'sub4', + p => [ + foo => \$String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => q{}, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => \*BARRY, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'bar' parameter \("GLOB\(0x[a-f0-9]+\)"\) to [\w:]+sub4 was a 'globref'.* types: glob|, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => *GLOBBY, + baz => do { local *FH; *FH; }, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'baz' parameter \((?:"\*[\w:]+FH"\|GLOB)\) to [\w:]+sub4 was a 'glob'.* types: globref|, + }, + + { + sub => 'sub4', + p => [ + foo => $String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'foo' parameter \("foo"\) to [\w:]+sub4 was a 'scalar'.* types: scalarref|, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => \*CODEREF, + ], + expect => + qr|^The 'quux' parameter \("GLOB\(0x[a-f0-9]+\)"\) to [\w:]+sub4 was a 'globref'.* types: coderef|, + }, + + # test HANDLE type + { + sub => 'sub4a', + p => [ foo => \*HANDLE ], + expect => q{}, + }, + + { + sub => 'sub4a', + p => [ foo => *HANDLE ], + expect => q{}, + }, + + { + sub => 'sub4a', + p => [ foo => ['not a handle'] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub4a was an 'arrayref'.* types: glob globref|, + }, + + # test BOOLEAN type + { + sub => 'sub4b', + p => [ foo => undef ], + expect => q{}, + }, + + { + sub => 'sub4b', + p => [ foo => 124125 ], + expect => q{}, + }, + + # isa + { + sub => 'sub5', + p => [ foo => $Foo ], + expect => q{}, + }, { + sub => 'sub5', + p => [ foo => $Bar ], + expect => q{}, + }, { + sub => 'sub5', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub6', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub6 was not a 'Bar'|, + }, { + sub => 'sub6', + p => [ foo => $Bar ], + expect => q{}, + }, { + sub => 'sub7', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub7', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub7 was not a 'Baz'|, + }, { + sub => 'sub7', + p => [ foo => $Bar ], + expect => + qr|^The 'foo' parameter \("Bar=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub7 was not a 'Baz'|, + }, { + sub => 'sub7', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub8', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub8 was not a 'Yadda'|, + }, + + { + sub => 'sub8', + p => [ foo => $Quux ], + expect => q{}, + }, + + # can + { + sub => 'sub9', + p => [ foo => $Foo ], + expect => q{}, + }, { + sub => 'sub9', + p => [ foo => $Quux ], + expect => q{}, + }, + + { + sub => 'sub9a', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9a does not have the method: 'barify'|, + }, { + sub => 'sub9a', + p => [ foo => $Bar ], + expect => q{}, + }, + + { + sub => 'sub9b', + p => [ foo => $Baz ], + expect => + qr|^The 'foo' parameter \("Baz=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9b does not have the method: 'yaddaify'|, + }, { + sub => 'sub9b', + p => [ foo => $Quux ], + expect => + qr|^The 'foo' parameter \("Quux=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9b does not have the method: 'barify'|, + }, + + { + sub => 'sub9c', + p => [ foo => $Bar ], + expect => + qr|^The 'foo' parameter \("Bar=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9c does not have the method: 'yaddaify'|, + }, + + { + sub => 'sub9c', + p => [ foo => $Quux ], + expect => q{}, + }, + + # callbacks + { + sub => 'sub10', + p => [ foo => 1 ], + expect => q{}, + }, + + { + sub => 'sub10', + p => [ foo => 19 ], + expect => q{}, + }, + + { + sub => 'sub10', + p => [ foo => 20 ], + expect => + qr|^The 'foo' parameter \("20"\) to [\w:]+sub10 did not pass the 'less than 20' callback|, + }, + + { + sub => 'sub11', + p => [ foo => 1 ], + expect => q{}, + }, { + sub => 'sub11', + p => [ foo => 20 ], + expect => + qr|^The 'foo' parameter \("20"\) to [\w:]+sub11 did not pass the 'less than 20' callback|, + }, + + { + sub => 'sub11', + p => [ foo => 0 ], + expect => + qr|^The 'foo' parameter \("0"\) to [\w:]+sub11 did not pass the 'more than 0' callback|, + }, + + # mix n' match + { + sub => 'sub12', + p => [ foo => 1 ], + expect => + qr|^The 'foo' parameter \("1"\) to [\w:]+sub12 was a 'scalar'.* types: arrayref|, + }, + + { + sub => 'sub12', + p => [ foo => [ 1, 2, 3 ] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub12 did not pass the '5 elements' callback|, + }, + + { + sub => 'sub12', + p => [ foo => [ 1, 2, 3, 4, 5 ] ], + expect => q{}, + }, + + # positional - 1 + { + sub => 'sub13', + p => ['a'], + expect => qr|^1 parameter was passed to .* but 2 were expected|, + }, + + { + sub => 'sub13', + p => [ 'a', [ 1, 2, 3 ] ], + expect => + qr|^Parameter #2 \("ARRAY\(0x[a-f0-9]+\)"\) to .* did not pass the '5 elements' callback|, + }, + + # positional - 2 + { + sub => 'sub14', + p => [ 'a', [ 1, 2, 3 ], $Foo ], + expect => + qr|^Parameter #3 \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to .* was not a 'Bar'|, + }, + + { + sub => 'sub14', + p => [ 'a', [ 1, 2, 3 ], $Bar ], + expect => q{}, + }, + + # hashref named params + { + sub => 'sub15', + p => [ { foo => 1, bar => { a => 1 } } ], + expect => + qr|^The 'bar' parameter \("HASH\(0x[a-f0-9]+\)"\) to .* was a 'hashref'.* types: arrayref|, + }, + + { + sub => 'sub15', + p => [ { foo => 1 } ], + expect => qr|^Mandatory parameter 'bar' missing|, + }, + + # positional - 3 + { + sub => 'sub16', + p => [ 1, 2, 3 ], + expect => qr|^3 parameters were passed .* but 1 - 2 were expected|, + }, + + { + sub => 'sub16', + p => [ 1, 2 ], + expect => q{}, + }, + + { + sub => 'sub16', + p => [1], + expect => q{}, + }, + + { + sub => 'sub16', + p => [], + expect => qr|^0 parameters were passed .* but 1 - 2 were expected|, + }, + + # positional - 4 + { + sub => 'sub17', + p => [ 1, 2, 3 ], + expect => qr|^3 parameters were passed .* but 1 - 2 were expected|, + }, + + { + sub => 'sub17', + p => [ 1, 2 ], + expect => q{}, + }, + + { + sub => 'sub17', + p => [1], + expect => q{}, + }, + + { + sub => 'sub17', + p => [], + expect => qr|^0 parameters were passed .* but 1 - 2 were expected|, + }, + + # positional - too few arguments supplied + { + sub => 'sub17a', + p => [], + expect => qr|^0 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17a', + p => [ 1, 2 ], + expect => qr|^2 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17b', + p => [], + expect => qr|^0 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17b', + p => [ 42, 2 ], + expect => qr|^2 parameters were passed .* but 3 - 4 were expected|, + }, + + # validation options - ignore case + { + sub => 'Foo::sub18', + p => [ FOO => 1 ], + options => { ignore_case => 1 }, + expect => q{}, + }, + + { + sub => 'sub18', + p => [ FOO => 1 ], + expect => qr|^The following parameter .* FOO|, + }, + + # validation options - strip leading + { + sub => 'Foo::sub18', + p => [ -foo => 1 ], + options => { strip_leading => '-' }, + expect => q{}, + }, + + { + sub => 'sub18', + p => [ -foo => 1 ], + expect => qr|^The following parameter .* -foo|, + }, + + # validation options - allow extra + { + sub => 'Foo::sub18', + p => [ foo => 1, bar => 1 ], + options => { allow_extra => 1 }, + expect => q{}, + return => { foo => 1, bar => 1 }, + }, + + { + sub => 'sub18', + p => [ foo => 1, bar => 1 ], + expect => qr|^The following parameter .* bar|, + }, + + { + sub => 'Foo::sub19', + p => [ 1, 2 ], + options => { allow_extra => 1 }, + expect => q{}, + return => [ 1, 2 ], + }, + + { + sub => 'sub19', + p => [ 1, 2 ], + expect => qr|^2 parameters were passed .* but 1.*|, + }, + + # validation options - on fail + { + sub => 'Foo::sub18', + p => [ bar => 1 ], + options => { + on_fail => sub { die "ERROR WAS: $_[0]" } + }, + expect => qr|^ERROR WAS: The following parameter .* bar|, + }, + + { + sub => 'sub18', + p => [ bar => 1 ], + expect => qr|^The following parameter .* bar|, + }, + + { + sub => 'sub20', + p => [ foo => undef ], + expect => qr|^The 'foo' parameter \(undef\) to .* was an 'undef'.*|, + }, + + { + sub => 'sub21', + p => [ foo => undef ], + expect => q{}, + }, + + { + sub => 'sub22', + p => [ foo => [1] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to .* was an 'arrayref'.*|, + }, + + { + sub => 'sub22', + p => [ foo => bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub22a', + p => [], + expect => q{}, + }, { + sub => 'sub22a', + p => [ foo => [1] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to .* was an 'arrayref'.*|, + }, { + sub => 'sub22a', + p => [ foo => bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub23', + p => ['1 element'], + expect => q{}, + }, + + { + sub => 'sub24', + p => [], + expect => q{}, + }, { + sub => 'sub24', + p => ['1 element'], + expect => qr|^Parameter #1 \("1 element"\) to .* was a 'scalar'.*|, + }, + + { + sub => 'sub24', + p => [ bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub25', + p => [1], + expect => qr|^Odd number|, + always_errors => 1, + }, + + # optional glob + { + sub => 'sub26', + p => [ + foo => 1, bar => do { local *BAR; *BAR } + ], + expect => q{}, + }, +); + +sub run_tests { + my $count = scalar @Tests; + $count++ for grep { $_->{return} } @Tests; + + for my $test (@Tests) { + if ( $test->{options} ) { + + package Foo; + validation_options( %{ $test->{options} } ); + } + + my $sub = $test->{sub}; + my @r = eval "$sub( \@{ \$test->{p} } )"; + + if ( + $test->{expect} + && ( $test->{always_errors} + || !$ENV{PERL_NO_VALIDATION} ) + ) { + like( $@, $test->{expect}, "expect error with $sub" ); + } + else { + is( $@, q{}, "no error with $sub" ); + } + + next unless $test->{return}; + + if ( eval { %{ $test->{return} } } ) { + my %r = @r; + is_deeply( + \%r, $test->{return}, + "check return value for $sub - hash" + ); + } + else { + is_deeply( + \@r, $test->{return}, + "check return value for $sub - array" + ); + } + } + + done_testing(); +} + +sub sub1 { + validate( @_, { foo => 1, bar => 1 } ); +} + +sub sub2 { + validate( @_, { foo => 1, bar => 1, baz => 0 } ); +} + +sub sub2a { + validate( @_, { foo => 1, bar => { optional => 1 } } ); +} + +sub sub3 { + validate( + @_, { + foo => { type => SCALAR }, + bar => + { type => ARRAYREF }, + baz => + { type => HASHREF }, + quux => + { type => SCALAR | ARRAYREF }, + brax => + { type => SCALAR | HASHREF }, + } + ); +} + +sub sub4 { + validate( + @_, { + foo => { type => SCALARREF }, + bar => + { type => GLOB }, + baz => + { type => GLOBREF }, + quux => + { type => CODEREF }, + } + ); +} + +sub sub4a { + validate( @_, { foo => { type => HANDLE } } ); +} + +sub sub4b { + validate( @_, { foo => { type => BOOLEAN } } ); +} + +sub sub5 { + validate( @_, { foo => { isa => 'Foo' } } ); +} + +sub sub6 { + validate( @_, { foo => { isa => 'Bar' } } ); +} + +sub sub7 { + validate( @_, { foo => { isa => 'Baz' } } ); +} + +sub sub8 { + validate( @_, { foo => { isa => [ 'Foo', 'Yadda' ] } } ); +} + +sub sub9 { + validate( @_, { foo => { can => 'fooify' } } ); +} + +sub sub9a { + validate( @_, { foo => { can => [ 'fooify', 'barify' ] } } ); +} + +sub sub9b { + validate( @_, { foo => { can => [ 'barify', 'yaddaify' ] } } ); +} + +sub sub9c { + validate( @_, { foo => { can => [ 'fooify', 'yaddaify' ] } } ); +} + +sub sub10 { + validate( + @_, { + foo => { + callbacks => { + 'less than 20' => sub { shift() < 20 } + } + } + } + ); +} + +sub sub11 { + validate( + @_, { + foo => { + callbacks => { + 'less than 20' => sub { shift() < 20 }, + 'more than 0' => sub { shift() > 0 }, + } + } + } + ); +} + +sub sub12 { + validate( + @_, { + foo => { + type => ARRAYREF, + callbacks => { + '5 elements' => sub { @{ shift() } == 5 } + } + } + } + ); +} + +sub sub13 { + validate_pos( + @_, + { type => SCALAR }, + { + type => ARRAYREF, + callbacks => { + '5 elements' => sub { @{ shift() } == 5 } + } + } + ); +} + +sub sub14 { + validate_pos( + @_, + { type => SCALAR }, + { type => ARRAYREF }, + { isa => 'Bar' }, + ); +} + +sub sub15 { + validate( + @_, { + foo => 1, + bar => { type => ARRAYREF } + } + ); +} + +sub sub16 { + validate_pos( @_, 1, 0 ); +} + +sub sub17 { + validate_pos( @_, { type => SCALAR }, { type => SCALAR, optional => 1 } ); +} + +{ + + package Foo; + use Params::Validate; + + sub sub18 { + validate( @_, { foo => 1 } ); + } + + sub sub19 { + validate_pos( @_, 1 ); + } +} + +sub sub17a { + validate_pos( @_, 1, 1, 1, 0 ); +} + +sub sub17b { + validate_pos( + @_, { + callbacks => { + 'less than 43' => sub { shift() < 43 } + } + }, + { type => SCALAR }, + 1, + { optional => 1 } + ); +} + +sub sub18 { + validate( @_, { foo => 1 } ); +} + +sub sub19 { + validate_pos( @_, 1 ); +} + +sub sub20 { + validate( @_, { foo => { type => SCALAR } } ); +} + +sub sub21 { + validate( @_, { foo => { type => UNDEF | SCALAR } } ); +} + +sub sub22 { + validate( @_, { foo => { type => OBJECT } } ); +} + +sub sub22a { + validate( @_, { foo => { type => OBJECT, optional => 1 } } ); +} + +sub sub23 { + validate_pos( @_, 1 ); +} + +sub sub24 { + validate_pos( @_, { type => OBJECT, optional => 1 } ); +} + +sub sub25 { + validate( @_, { foo => 1 } ); +} + +sub sub26 { + validate( + @_, { + foo => { type => SCALAR }, + bar => + { type => HANDLE, optional => 1 }, + }, + ); +} + +package Foo; + +use Params::Validate qw(:all); + +sub fooify {1} + +package Bar; + +@Bar::ISA = ('Foo'); + +sub barify {1} + +package Baz; + +@Baz::ISA = ('Bar'); + +sub bazify {1} + +package Yadda; + +sub yaddaify {1} + +package Quux; + +@Quux::ISA = ( 'Foo', 'Yadda' ); + +sub quuxify {1} + +1; diff --git a/t/lib/PVTests/With.pm b/t/lib/PVTests/With.pm new file mode 100644 index 0000000..e7ef350 --- /dev/null +++ b/t/lib/PVTests/With.pm @@ -0,0 +1,125 @@ +package PVTests::With; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + eval { validate_with( params => ['foo'], spec => [SCALAR], ); }; + is( $@, q{} ); + + eval { + validate_with( + params => { + foo => 5, + bar => {} + }, + spec => { + foo => SCALAR, + bar => HASHREF + }, + ); + }; + is( $@, q{} ); + + eval { + validate_with( + params => [], + spec => [SCALAR], + called => 'Yo::Mama', + ); + }; + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/Yo::Mama/ ); + } + + { + my %p; + eval { + %p = validate_with( + params => [], + spec => { + a => { default => 3 }, + b => { default => 'x' } + }, + ); + }; + + ok( exists $p{a} ); + is( $p{a}, 3 ); + ok( exists $p{b} ); + is( $p{b}, 'x' ); + } + + { + my @p; + eval { + @p = validate_with( + params => [], + spec => [ + { default => 3 }, + { default => 'x' } + ], + ); + }; + + is( $p[0], 3 ); + is( $p[1], 'x' ); + } + + { + + package Testing::X; + use Params::Validate qw(:all); + validation_options( allow_extra => 1 ); + + eval { + validate_with( + params => [ a => 1, b => 2, c => 3 ], + spec => { a => 1, b => 1 }, + ); + }; + PVTests::With::is( $@, q{} ); + + eval { + validate_with( + params => [ a => 1, b => 2, c => 3 ], + spec => { a => 1, b => 1 }, + allow_extra => 0, + ); + }; + if ( $ENV{PERL_NO_VALIDATION} ) { + PVTests::With::is( $@, q{} ); + } + else { + PVTests::With::like( $@, qr/was not listed/ ); + } + } + + { + + # Bug 2791 on rt.cpan.org + my %p; + eval { + my @p = { foo => 1 }; + %p = validate_with( + params => \@p, + spec => { foo => 1 }, + ); + }; + + is( $@, q{} ); + is( $p{foo}, 1 ); + } + + done_testing(); +} + +1; diff --git a/t/release-cpan-changes.t b/t/release-cpan-changes.t new file mode 100644 index 0000000..214650f --- /dev/null +++ b/t/release-cpan-changes.t @@ -0,0 +1,19 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; + +use Test::More 0.96 tests => 2; +use_ok('Test::CPAN::Changes'); +subtest 'changes_ok' => sub { + changes_file_ok('Changes'); +}; +done_testing(); diff --git a/t/release-memory-leak.t b/t/release-memory-leak.t new file mode 100644 index 0000000..0543aab --- /dev/null +++ b/t/release-memory-leak.t @@ -0,0 +1,105 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => q{Test::LeakTrace doesn't install with blead (as of 5.21.8)} + if $] >= 5.021008; +} + +use Test::LeakTrace qw( no_leaks_ok ); + +use Params::Validate qw( validate ); + +subtest( + 'callback with default error' => sub { + no_leaks_ok( sub { val1( foo => 42 ); }, 'validation passes' ); + local $TODO = 'Not sure if all the leaks are in Carp or not'; + no_leaks_ok( + sub { + eval { val1( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +subtest( + 'callback that dies with string' => sub { + no_leaks_ok( sub { val2( foo => 42 ); }, 'validation passes' ); + local $TODO = 'Not sure if all the leaks are in Carp or not'; + no_leaks_ok( + sub { + eval { val2( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +subtest( + 'callback that dies with object' => sub { + no_leaks_ok( sub { val3( foo => 42 ); }, 'validation passes' ); + no_leaks_ok( + sub { + eval { val3( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +done_testing(); + +sub val1 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { $_[0] =~ /^[0-9]+$/ } + } + }, + }, + ); +} + +sub val2 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { + $_[0] =~ /^[0-9]+$/ or die "$_[0] is not an integer"; + } + } + }, + }, + ); +} + +sub val3 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { + $_[0] =~ /^[0-9]+$/ + or die { error => "$_[0] is not an integer" }; + } + } + }, + }, + ); +} diff --git a/t/release-pod-coverage.t b/t/release-pod-coverage.t new file mode 100644 index 0000000..48d555f --- /dev/null +++ b/t/release-pod-coverage.t @@ -0,0 +1,56 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +# This file was automatically generated by Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable. + +use Test::Pod::Coverage 1.08; +use Test::More 0.88; + +BEGIN { + if ( $] <= 5.008008 ) { + plan skip_all => 'These tests require Pod::Coverage::TrustPod, which only works with Perl 5.8.9+'; + } +} +use Pod::Coverage::TrustPod; + +my %skip = map { $_ => 1 } qw( Params::Validate::Constants Params::Validate::PP Params::Validate::XS Params::ValidatePP Params::ValidateXS ); + +my @modules; +for my $module ( all_modules() ) { + next if $skip{$module}; + + push @modules, $module; +} + +plan skip_all => 'All the modules we found were excluded from POD coverage test.' + unless @modules; + +plan tests => scalar @modules; + +my %trustme = ( + 'Params::Validate' => [ + qr/^(?:UNKNOWN|set_options|validate(?:_pos|_with)?|validation_options)$/ + ] + ); + +my @also_private; + +for my $module ( sort @modules ) { + pod_coverage_ok( + $module, + { + coverage_class => 'Pod::Coverage::TrustPod', + also_private => \@also_private, + trustme => $trustme{$module} || [], + }, + "pod coverage for $module" + ); +} + +done_testing(); diff --git a/t/release-pod-linkcheck.t b/t/release-pod-linkcheck.t new file mode 100644 index 0000000..654cf06 --- /dev/null +++ b/t/release-pod-linkcheck.t @@ -0,0 +1,28 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_LINKCHECK +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::LinkCheck"; +if ( $@ ) { + plan skip_all => 'Test::Pod::LinkCheck required for testing POD'; +} +else { + Test::Pod::LinkCheck->new->all_pod_ok; +} diff --git a/t/release-pod-no404s.t b/t/release-pod-no404s.t new file mode 100644 index 0000000..da185ec --- /dev/null +++ b/t/release-pod-no404s.t @@ -0,0 +1,29 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_NO404S + AUTOMATED_TESTING +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::No404s"; +if ( $@ ) { + plan skip_all => 'Test::Pod::No404s required for testing POD'; +} +else { + all_pod_files_ok(); +} diff --git a/t/release-pod-syntax.t b/t/release-pod-syntax.t new file mode 100644 index 0000000..cdd6a6c --- /dev/null +++ b/t/release-pod-syntax.t @@ -0,0 +1,14 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); diff --git a/t/release-portability.t b/t/release-portability.t new file mode 100644 index 0000000..ad285b4 --- /dev/null +++ b/t/release-portability.t @@ -0,0 +1,20 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; + +use Test::More; + +eval 'use Test::Portability::Files'; +plan skip_all => 'Test::Portability::Files required for testing portability' + if $@; + +run_tests(); diff --git a/t/release-pp-01-validate.t b/t/release-pp-01-validate.t new file mode 100644 index 0000000..da6a1fd --- /dev/null +++ b/t/release-pp-01-validate.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/release-pp-02-noop.t b/t/release-pp-02-noop.t new file mode 100644 index 0000000..bcac392 --- /dev/null +++ b/t/release-pp-02-noop.t @@ -0,0 +1,24 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Standard; +PVTests::Standard::run_tests(); + + diff --git a/t/release-pp-03-attribute.t b/t/release-pp-03-attribute.t new file mode 100644 index 0000000..9c6a208 --- /dev/null +++ b/t/release-pp-03-attribute.t @@ -0,0 +1,114 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Attribute::Params::Validate; +use Params::Validate qw(:all); + +sub foo : Validate( c => { type => SCALAR } ) { + my %data = @_; + return $data{c}; +} + +sub bar : Validate( c => { type => SCALAR } ) method { + my $self = shift; + my %data = @_; + return $data{c}; +} + +sub baz : + Validate( foo => { type => ARRAYREF, callbacks => { '5 elements' => sub { @{shift()} == 5 } } } ) +{ + my %data = @_; + return $data{foo}->[0]; +} + +sub buz : ValidatePos( 1 ) { + return $_[0]; +} + +sub quux : ValidatePos( { type => SCALAR }, 1 ) { + return $_[0]; +} + +my $res = eval { foo( c => 1 ) }; +is( + $@, q{}, + "Call foo with a scalar" +); + +is( + $res, 1, + 'Check return value from foo( c => 1 )' +); + +eval { foo( c => [] ) }; + +like( + $@, qr/The 'c' parameter .* was an 'arrayref'/, + 'Check exception thrown from foo( c => [] )' +); + +$res = eval { main->bar( c => 1 ) }; +is( + $@, q{}, + 'Call bar with a scalar' +); + +is( + $res, 1, + 'Check return value from bar( c => 1 )' +); + +eval { baz( foo => [ 1, 2, 3, 4 ] ) }; + +like( + $@, qr/The 'foo' parameter .* did not pass the '5 elements' callback/, + 'Check exception thrown from baz( foo => [1,2,3,4] )' +); + +$res = eval { baz( foo => [ 5, 4, 3, 2, 1 ] ) }; + +is( + $@, q{}, + 'Call baz( foo => [5,4,3,2,1] )' +); + +is( + $res, 5, + 'Check return value from baz( foo => [5,4,3,2,1] )' +); + +eval { buz( [], 1 ) }; + +like( + $@, qr/2 parameters were passed to .* but 1 was expected/, + 'Check exception thrown from quux( [], 1 )' +); + +$res = eval { quux( 1, [] ) }; + +is( + $@, q{}, + 'Call quux' +); + +done_testing(); + diff --git a/t/release-pp-04-defaults.t b/t/release-pp-04-defaults.t new file mode 100644 index 0000000..8ed39d4 --- /dev/null +++ b/t/release-pp-04-defaults.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); + diff --git a/t/release-pp-05-noop_default.t b/t/release-pp-05-noop_default.t new file mode 100644 index 0000000..82b2c00 --- /dev/null +++ b/t/release-pp-05-noop_default.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); + diff --git a/t/release-pp-06-options.t b/t/release-pp-06-options.t new file mode 100644 index 0000000..a18c245 --- /dev/null +++ b/t/release-pp-06-options.t @@ -0,0 +1,52 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Params::Validate qw(:all); + +validation_options( stack_skip => 2 ); + +sub foo { + my %p = validate( @_, { bar => 1 } ); +} + +sub bar { foo(@_) } + +sub baz { bar(@_) } + +eval { baz() }; + +like( $@, qr/mandatory.*missing.*call to main::bar/i ); + +validation_options( stack_skip => 3 ); + +eval { baz() }; +like( $@, qr/mandatory.*missing.*call to main::baz/i ); + +validation_options( on_fail => sub { die bless { hash => 'ref' }, 'Dead' } ); + +eval { baz() }; + +my $e = $@; +is( $e->{hash}, 'ref' ); +ok( eval { $e->isa('Dead'); 1; } ); + +done_testing(); + diff --git a/t/release-pp-07-with.t b/t/release-pp-07-with.t new file mode 100644 index 0000000..1b3bdf0 --- /dev/null +++ b/t/release-pp-07-with.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::With; +PVTests::With::run_tests(); + diff --git a/t/release-pp-08-noop_with.t b/t/release-pp-08-noop_with.t new file mode 100644 index 0000000..7705999 --- /dev/null +++ b/t/release-pp-08-noop_with.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::With; +PVTests::With::run_tests(); + diff --git a/t/release-pp-09-regex.t b/t/release-pp-09-regex.t new file mode 100644 index 0000000..ddaed55 --- /dev/null +++ b/t/release-pp-09-regex.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Regex; +PVTests::Regex::run_tests(); + diff --git a/t/release-pp-10-noop_regex.t b/t/release-pp-10-noop_regex.t new file mode 100644 index 0000000..b7f8e2b --- /dev/null +++ b/t/release-pp-10-noop_regex.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Regex; +PVTests::Regex::run_tests(); + diff --git a/t/release-pp-11-cb.t b/t/release-pp-11-cb.t new file mode 100644 index 0000000..a8b9d41 --- /dev/null +++ b/t/release-pp-11-cb.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); + diff --git a/t/release-pp-12-noop_cb.t b/t/release-pp-12-noop_cb.t new file mode 100644 index 0000000..62a6fbb --- /dev/null +++ b/t/release-pp-12-noop_cb.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); + diff --git a/t/release-pp-13-taint.t b/t/release-pp-13-taint.t new file mode 100644 index 0000000..659addd --- /dev/null +++ b/t/release-pp-13-taint.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +eval { "$0$^X" && kill 0; 1 }; + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/release-pp-14-no_validate.t b/t/release-pp-14-no_validate.t new file mode 100644 index 0000000..3549bbf --- /dev/null +++ b/t/release-pp-14-no_validate.t @@ -0,0 +1,41 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use lib './t'; + +use Params::Validate qw(validate); + +use Test::More; +plan tests => $] == 5.006 ? 2 : 3; + +eval { foo() }; +like( $@, qr/parameter 'foo'/ ); + +{ + local $Params::Validate::NO_VALIDATION = 1; + + eval { foo() }; + is( $@, q{} ); +} + +unless ( $] == 5.006 ) { + eval { foo() }; + like( $@, qr/parameter 'foo'/ ); +} + +sub foo { + validate( @_, { foo => 1 } ); +} + diff --git a/t/release-pp-15-case.t b/t/release-pp-15-case.t new file mode 100644 index 0000000..7c5bd04 --- /dev/null +++ b/t/release-pp-15-case.t @@ -0,0 +1,111 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw(validate validate_with); + +my @testset; + +# Generate test cases ... +BEGIN { + my @lower_case_args = ( foo => 1 ); + my @upper_case_args = ( FOO => 1 ); + my @mixed_case_args = ( FoO => 1 ); + + my %lower_case_spec = ( foo => 1 ); + my %upper_case_spec = ( FOO => 1 ); + my %mixed_case_spec = ( FoO => 1 ); + + my %arglist = ( + lower => \@lower_case_args, + upper => \@upper_case_args, + mixed => \@mixed_case_args + ); + + my %speclist = ( + lower => \%lower_case_spec, + upper => \%upper_case_spec, + mixed => \%mixed_case_spec + ); + + # XXX - make subs such that user gets to see the error message + # when a test fails + my $ok_sub = sub { + if ($@) { + print STDERR $@; + } + !$@; + }; + + my $nok_sub = sub { + my $ok = ( $@ =~ /not listed in the validation options/ ); + unless ($ok) { + print STDERR $@; + } + $ok; + }; + + # generate testcases on the fly (I'm too lazy) + for my $ignore_case (qw( 0 1 )) { + for my $args ( keys %arglist ) { + for my $spec ( keys %speclist ) { + push @testset, { + params => $arglist{$args}, + spec => $speclist{$spec}, + expect => ( + $ignore_case ? $ok_sub + : $args eq $spec ? $ok_sub + : $nok_sub + ), + ignore_case => $ignore_case + }; + } + } + } +} + +plan tests => ( scalar @testset ) * 2; + +{ + + # XXX - "called" will be all messed up, but what the heck + foreach my $case (@testset) { + my %args = eval { + validate_with( + params => $case->{params}, + spec => $case->{spec}, + ignore_case => $case->{ignore_case} + ); + }; + + ok( $case->{expect}->(%args) ); + } + + # XXX - make sure that it works from validation_options() as well + foreach my $case (@testset) { + Params::Validate::validation_options( + ignore_case => $case->{ignore_case} ); + + my %args = eval { + my @args = @{ $case->{params} }; + validate( @args, $case->{spec} ); + }; + + ok( $case->{expect}->(%args) ); + } +} + + diff --git a/t/release-pp-16-normalize.t b/t/release-pp-16-normalize.t new file mode 100644 index 0000000..de2a994 --- /dev/null +++ b/t/release-pp-16-normalize.t @@ -0,0 +1,84 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_with); +use Test::More; + +my $ucfirst_normalizer = sub { return ucfirst lc $_[0] }; + +sub sub1 { + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer + ); + + return $args{Paramkey}; +} + +sub sub2 { + + # verify that normalize_callback surpresses ignore_case + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + ignore_case => 1 + ); + + return $args{Paramkey}; +} + +sub sub3 { + + # verify that normalize_callback surpresses strip_leading + my %args = validate_with( + params => \@_, + spec => { -PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + strip_leading => '-' + ); + + return $args{-paramkey}; +} + +sub sub4 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub {undef} + ); +} + +sub sub5 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub { return 'a' }, + ); +} + +ok( eval { sub1( pArAmKeY => 1 ) } ); +ok( eval { sub2( pArAmKeY => 1 ) } ); +ok( eval { sub3( -pArAmKeY => 1 ) } ); + +eval { sub4( foo => 5 ) }; +like( $@, qr/normalize_keys.+a defined value/ ); + +eval { sub5( foo => 5, bar => 5 ) }; +like( $@, qr/normalize_keys.+already exists/ ); + +done_testing(); + diff --git a/t/release-pp-17-callbacks.t b/t/release-pp-17-callbacks.t new file mode 100644 index 0000000..6fdaa86 --- /dev/null +++ b/t/release-pp-17-callbacks.t @@ -0,0 +1,91 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/bigger than bar/ ); + + $p[1] = 3; + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + is( $@, q{} ); +} + +{ + my @p = ( 1, 2, 3 ); + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + like( $@, qr/bigger than \[1\]/ ); + + $p[0] = 5; + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + is( $@, q{} ); +} + +done_testing(); + diff --git a/t/release-pp-18-depends.t b/t/release-pp-18-depends.t new file mode 100644 index 0000000..c1f31b6 --- /dev/null +++ b/t/release-pp-18-depends.t @@ -0,0 +1,181 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +{ + my %spec = ( + foo => { optional => 1, depends => 'bar' }, + bar => { optional => 1 }, + ); + + my @args = ( bar => 1 ); + + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(1): no depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(2): with depends, positive" ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() single depends(3.a): with depends, negative" ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'bar', which was not given), + "validate() single depends(3.b): check error string" + ); +} + +{ + my %spec = ( + foo => { optional => 1, depends => [qw(bar baz)] }, + bar => { optional => 1 }, + baz => { optional => 1 }, + ); + + # positive, no depends (single, multiple) + my @args = ( bar => 1 ); + eval { validate( @args, \%spec ) }; + is( + $@, q{}, + "validate() multiple depends(1): no depends, single arg, positive" + ); + + @args = ( bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( + $@, q{}, + "validate() multiple depends(2): no depends, multiple arg, positive" + ); + + @args = ( foo => 1, bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() multiple depends(3): with depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(4.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'baz', which was not given), + "validate() multiple depends (4.b): check error string" + ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(5.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter '(bar|baz)', which was not given), + "validate() multiple depends (5.b): check error string" + ); +} + +{ + + # bad depends + my %spec = ( + foo => { optional => 1, depends => { 'bar' => 1 } }, + bar => { optional => 1 }, + ); + + my @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() bad depends spec (1.a): depends is a hashref" ); + like( + $@, + qr(^Arguments to 'depends' must be a scalar or arrayref), + "validate() bad depends spec (1.a): check error string" + ); +} + +{ + my @spec = ( { optional => 1 } ); + + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + is( $@, q{}, "validate_pos() no depends, positive" ); +} + +{ + my @spec = ( { optional => 1, depends => 2 }, { optional => 1 } ); + + my @args = qw(1 1); + eval { validate_pos( @args, @spec ) }; + + is( + $@, q{}, + "validate_pos() single depends (1): with depends, positive" + ); +} + +{ + my @spec = ( + { optional => 1, depends => 4 }, + { optional => 1 }, { optional => 1 }, + { optional => 1 } + ); + + my @args = qw(1 0); + eval { validate_pos( @args, @spec ) }; + + ok( $@, "validate_pos() single depends (2.a): with depends, negative" ); + like( + $@, + qr(^Parameter #1 depends on parameter #4, which was not given), + "validate_pos() single depends (2.b): check error" + ); +} + +{ + my @spec = ( + { optional => 1, depends => [ 2, 3 ] }, + { optional => 1 }, + 0 + ); + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + ok( + $@, + "validate_pos() multiple depends (1.a): with depends, bad args negative" + ); + like( + $@, + qr{^Arguments to 'depends' for validate_pos\(\) must be a scalar}, + "validate_pos() multiple depends (1.b): check error" + ); +} + +done_testing(); + diff --git a/t/release-pp-19-untaint.t b/t/release-pp-19-untaint.t new file mode 100644 index 0000000..42ee82d --- /dev/null +++ b/t/release-pp-19-untaint.t @@ -0,0 +1,99 @@ +#!/usr/bin/perl -T + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + untaint => 1, + }, + }, + ); + + untainted_ok( $p{value}, 'value is untainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + untaint => 1, + }, + ); + + untainted_ok( $new_value, 'value is untainted after validation' ); +} + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + }, + }, + ); + + tainted_ok( $p{value}, 'value is still tainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + }, + ); + + tainted_ok( $new_value, 'value is still tainted after validation' ); +} + +done_testing(); + diff --git a/t/release-pp-21-can.t b/t/release-pp-21-can.t new file mode 100644 index 0000000..2c81979 --- /dev/null +++ b/t/release-pp-21-can.t @@ -0,0 +1,108 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassCan' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'baz' } }, ); }; + + like( $@, qr/does not have the method: 'baz'/ ); +} + +{ + my $object = bless {}, 'ClassCan'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my $object = bless {}, 'SubClass'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass object->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'unblessed ref ->can' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'number can' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'string can' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'undef can' ); +} + +done_testing(); + +package ClassCan; + +sub can { + return 1 if $_[1] eq 'cancan'; + return 0; +} + +sub thingy {1} + +package SubClass; + +use base 'ClassCan'; + diff --git a/t/release-pp-22-overload-can-bug.t b/t/release-pp-22-overload-can-bug.t new file mode 100644 index 0000000..44acf60 --- /dev/null +++ b/t/release-pp-22-overload-can-bug.t @@ -0,0 +1,50 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + package Overloaded; + + use overload 'bool' => sub {0}; + + sub new { bless {} } + + sub foo {1} +} + +my $ovl = Overloaded->new; + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { isa => 'Overloaded' } } ); + }; + + is( $@, q{}, 'overloaded object->isa' ); +} + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { can => 'foo' } } ); + }; + + is( $@, q{}, 'overloaded object->foo' ); +} + +done_testing(); + diff --git a/t/release-pp-23-readonly.t b/t/release-pp-23-readonly.t new file mode 100644 index 0000000..8c4a521 --- /dev/null +++ b/t/release-pp-23-readonly.t @@ -0,0 +1,52 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Requires { + Readonly => '1.03', + 'Scalar::Util' => '1.20', +}; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +plan skip_all => 'These tests fail with Readonly 1.50 for some reason' + if Readonly::->VERSION() =~ /^v?1.5/; + +{ + Readonly my $spec => { foo => 1 }; + my @p = ( foo => 'hello' ); + + eval { validate( @p, $spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my $spec => { type => SCALAR }; + my @p = 'hello'; + + eval { validate_pos( @p, $spec ) }; + is( $@, q{}, 'validate_pos() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my %spec => ( foo => { type => SCALAR } ); + my @p = ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hash' ); +} + +done_testing(); + diff --git a/t/release-pp-24-tied.t b/t/release-pp-24-tied.t new file mode 100644 index 0000000..2522b60 --- /dev/null +++ b/t/release-pp-24-tied.t @@ -0,0 +1,134 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + package Tie::SimpleArray; + use Tie::Array; + use base 'Tie::StdArray'; +} + +{ + + package Tie::SimpleHash; + use Tie::Hash; + use base 'Tie::StdHash'; +} + +{ + tie my @p, 'Tie::SimpleArray'; + + my %spec = ( foo => 1 ); + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and tied hashref spec' + ); +} + +{ + tie my @p, 'Tie::SimpleArray'; + my %spec; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and tied hashref spec' + ); +} + +done_testing(); + diff --git a/t/release-pp-25-undef-regex.t b/t/release-pp-25-undef-regex.t new file mode 100644 index 0000000..7f20da4 --- /dev/null +++ b/t/release-pp-25-undef-regex.t @@ -0,0 +1,30 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @w; + local $SIG{__WARN__} = sub { push @w, @_ }; + + my @p = ( foo => undef ); + eval { validate( @p, { foo => { regex => qr/^bar/ } } ) }; + ok( $@, 'validation failed' ); + ok( !@w, 'no warnings' ); +} + +done_testing(); + diff --git a/t/release-pp-26-isa.t b/t/release-pp-26-isa.t new file mode 100644 index 0000000..f95fdd5 --- /dev/null +++ b/t/release-pp-26-isa.t @@ -0,0 +1,102 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassISA' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'no error checking if ClassISA->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + like( $@, qr/was not a 'FooBar'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => bless {}, 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'unblessed ref ->isa' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'number isa' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'string isa' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'undef isa' ); +} + +done_testing(); + +package ClassISA; + +sub isa { + return 1 if $_[1] eq 'FooBar'; + return $_[0]->SUPER::isa( $_[1] ); +} + +sub thingy {1} + +package SubClass; + +use base 'ClassISA'; + diff --git a/t/release-pp-27-string-as-type.t b/t/release-pp-27-string-as-type.t new file mode 100644 index 0000000..bb19f37 --- /dev/null +++ b/t/release-pp-27-string-as-type.t @@ -0,0 +1,43 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => 'SCALAR' } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is a string - SCALAR/ + ); +} + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => undef } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is undef/ + ); + +} + +done_testing(); + diff --git a/t/release-pp-28-readonly-return.t b/t/release-pp-28-readonly-return.t new file mode 100644 index 0000000..1dedca0 --- /dev/null +++ b/t/release-pp-28-readonly-return.t @@ -0,0 +1,106 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; +use Test::More; + +use Devel::Peek qw( SvREFCNT ); +use File::Temp qw( tempfile ); +use Params::Validate qw( validate SCALAR HANDLE ); + +{ + my $fh = tempfile(); + my @p = ( + foo => 1, + bar => $fh, + ); + + my $ref = val1(@p); + + eval { $ref->{foo} = 2 }; + ok( !$@, 'returned hashref values are not read only' ); + is( $ref->{foo}, 2, 'double check that setting value worked' ); + is( $fh, $ref->{bar}, 'filehandle is not copied during validation' ); +} + +{ + + package ScopeTest; + + my $live = 0; + + sub new { $live++; bless {}, shift } + sub DESTROY { $live-- } + + sub Live {$live} +} + +{ + my @p = ( foo => ScopeTest->new() ); + + is( + ScopeTest->Live(), 1, + 'one live object' + ); + + my $ref = val2(@p); + + isa_ok( $ref->{foo}, 'ScopeTest' ); + + @p = (); + + is( + ScopeTest->Live(), 1, + 'still one live object' + ); + + ok( + defined $ref->{foo}, + 'foo key stays in scope after original version goes out of scope' + ); + is( + SvREFCNT( $ref->{foo} ), 1, + 'ref count for reference is 1' + ); + + undef $ref->{foo}; + + is( + ScopeTest->Live(), 0, + 'no live objects' + ); +} + +sub val1 { + my $ref = validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HANDLE, optional => 1 }, + }, + ); + + return $ref; +} + +sub val2 { + my $ref = validate( + @_, { + foo => 1, + }, + ); + + return $ref; +} + +done_testing(); + diff --git a/t/release-pp-29-taint-mode.t b/t/release-pp-29-taint-mode.t new file mode 100644 index 0000000..6e8b60d --- /dev/null +++ b/t/release-pp-29-taint-mode.t @@ -0,0 +1,65 @@ +#!perl -T + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Test::Fatal; +use Test::More; + +use Params::Validate qw( validate validate_pos ARRAYREF ); + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +sub test1 { + my $def = $0; + tainted_ok( $def, 'make sure $def is tainted' ); + + # The spec is irrelevant, all that matters is that there's a + # tainted scalar as the default + my %p = validate( @_, { foo => { default => $def } } ); +} + +{ + is( + exception { test1() }, + undef, + 'no taint error when we validate with tainted default value' + ); +} + +sub test2 { + return validate_pos( @_, { regex => qr/^b/ } ); +} + +SKIP: +{ + skip 'This test only passes on Perl 5.14+', 1 + unless $] >= 5.014; + + my @p = 'cat'; + taint(@p); + + like( + exception { test2(@p) }, + qr/\QParameter #1 ("cat") to main::test2 did not pass regex check/, + 'no taint error when we validate with tainted value values being validated' + ); +} + +done_testing(); + diff --git a/t/release-pp-30-hashref-alteration.t b/t/release-pp-30-hashref-alteration.t new file mode 100644 index 0000000..d1571cb --- /dev/null +++ b/t/release-pp-30-hashref-alteration.t @@ -0,0 +1,64 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; +use Test::More; + +use Params::Validate qw( validate SCALAR ); + +{ + my $p = { foo => 1 }; + + val($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val' + ); + + val2($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val, even with defaults being supplied' + ); +} + +sub val { + validate( + @_, { + foo => { optional => 1 }, + bar => { optional => 1 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +sub val2 { + validate( + @_, { + foo => { optional => 1 }, + bar => { default => 42 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +done_testing(); + diff --git a/t/release-pp-31-incorrect-spelling.t b/t/release-pp-31-incorrect-spelling.t new file mode 100644 index 0000000..98f32c2 --- /dev/null +++ b/t/release-pp-31-incorrect-spelling.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw( validate validate_pos SCALAR ); + +plan skip_all => 'Spec validation is disabled for now'; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbucks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + + eval { + validate( + @p, { + foo => { + hype => SCALAR, + callbacks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + eval { + validate( + @p, { + foo => { + type => SCALAR, + regexp => qr/^\d+$/, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); +} + +done_testing(); + diff --git a/t/release-pp-32-regex-as-value.t b/t/release-pp-32-regex-as-value.t new file mode 100644 index 0000000..4eb0d05 --- /dev/null +++ b/t/release-pp-32-regex-as-value.t @@ -0,0 +1,50 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR SCALARREF ); + +use Test::More; +use Test::Fatal; + +is( + exception { v( foo => qr/foo/ ) }, + undef, + 'no exception with regex object' +); + +is( + exception { v( foo => 'foo' ) }, + undef, + 'no exception with plain scalar' +); + +my $foo = 'foo'; +is( + exception { v( foo => \$foo ) }, + undef, + 'no exception with scalar ref' +); + +done_testing(); + +sub v { + validate( + @_, { + foo => { type => SCALAR | SCALARREF }, + }, + ); + return; +} + diff --git a/t/release-pp-33-keep-errsv.t b/t/release-pp-33-keep-errsv.t new file mode 100644 index 0000000..24f3ded --- /dev/null +++ b/t/release-pp-33-keep-errsv.t @@ -0,0 +1,36 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR ); + +use Test::More; + +{ + $@ = 'foo'; + v( bar => 42 ); + + is( + $@, + 'foo', + 'calling validate() does not clobber' + ); +} + +done_testing(); + +sub v { + validate( @_, { bar => { type => SCALAR } } ); +} + diff --git a/t/release-pp-34-recursive-validation.t b/t/release-pp-34-recursive-validation.t new file mode 100644 index 0000000..9dc6194 --- /dev/null +++ b/t/release-pp-34-recursive-validation.t @@ -0,0 +1,67 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate SCALAR ); + + Params::Validate::validation_options( allow_extra => 1 ); + + sub test_foo { + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + print "test foo\n"; + } +} + +{ + package Bar; + + use Params::Validate qw( validate SCALAR ); + Params::Validate::validation_options( allow_extra => 0 ); + + sub test_bar { + + # catch die signal + local $SIG{__DIE__} = sub { + + # we died from within Params::Validate (because of wrong_Arg) we + # call Foo::test_foo with OK args, but it'll die, because + # Params::Validate::PP::options is still set to the options of the + # Bar package, and so it won't retreive the one from Foo. + Foo::test_foo( arg1 => 1, extra_arg => 2 ); + }; + + # this will die because the arg received is 'wrong_arg' + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + } +} + +{ + # This bug only manifests with the pure Perl code because of its use of local + # to remember the per-package options. + local $TODO = 'Not sure how to fix this one'; + unlike( + exception { Bar::test_bar( bad_arg => 2 ) }, + qr/was passed in the call to Foo::test_foo/, + 'no exception from Foo::test_foo when when calling validate() from within a __DIE__ handler' + ); +} + +done_testing(); + diff --git a/t/release-pp-35-default-xs-bug.t b/t/release-pp-35-default-xs-bug.t new file mode 100644 index 0000000..feec141 --- /dev/null +++ b/t/release-pp-35-default-xs-bug.t @@ -0,0 +1,34 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More 0.88; + +use Params::Validate qw( :all ); + +default_test(); + +done_testing(); + +sub default_test { + my ( $first, $second ) = validate_pos( + @_, + { type => SCALAR, optional => 1 }, + { type => SCALAR, optional => 1, default => 'must be second one' }, + ); + + is( $first, undef, '01 no default for first' ); + is( $second, 'must be second one', '01 default for second' ); +} + diff --git a/t/release-pp-36-large-arrays.t b/t/release-pp-36-large-arrays.t new file mode 100644 index 0000000..6301d91 --- /dev/null +++ b/t/release-pp-36-large-arrays.t @@ -0,0 +1,55 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate ARRAYREF ); + + sub v1 { + my %p = validate( + @_, { + array => { + callbacks => { + 'checking array contents' => sub { + for my $x ( @{ $_[0] } ) { + return 0 unless defined $x && !ref $x; + } + return 1; + }, + } + } + } + ); + return $p{array}; + } +} + +{ + for my $size ( 100, 1_000, 100_000 ) { + my @array = ('x') x $size; + is_deeply( + Foo::v1( array => \@array ), + \@array, + "validate() handles $size element array correctly" + ); + } +} + +done_testing(); + diff --git a/t/release-pp-37-exports.t b/t/release-pp-37-exports.t new file mode 100644 index 0000000..607aefc --- /dev/null +++ b/t/release-pp-37-exports.t @@ -0,0 +1,65 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; +use Params::Validate (); + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +my @subs = qw( + validate + validate_pos + validation_options + validate_with +); + +is_deeply( + [ sort @Params::Validate::EXPORT_OK ], + [ sort @types, @subs, 'set_options' ], + '@EXPORT_OK' +); + +is_deeply( + [ sort keys %Params::Validate::EXPORT_TAGS ], + [qw( all types )], + 'keys %EXPORT_TAGS' +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{all} } ], + [ sort @types, @subs ], + '$EXPORT_TAGS{all}', +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{types} } ], + [ sort @types ], + '$EXPORT_TAGS{types}', +); + +done_testing(); + diff --git a/t/release-pp-38-callback-message.t b/t/release-pp-38-callback-message.t new file mode 100644 index 0000000..8e1f2c2 --- /dev/null +++ b/t/release-pp-38-callback-message.t @@ -0,0 +1,126 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; +use Params::Validate qw( validate ); + +{ + my $e = _test_args( + pos_int => 42, + string => 'foo', + ); + is( + $e, + q{}, + 'no error with good args' + ); +} + +{ + my $e = _test_args( + pos_int => 42, + string => [], + ); + like( + $e, + qr/The 'string' parameter \("ARRAY\(.+\)"\) to main::validate1 did not pass the 'string' callback: ARRAY\(.+\) is not a string/, + 'got error for bad string' + ); +} + +{ + my $e = _test_args( + pos_int => 0, + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("0") to main::validate1 did not pass the 'pos_int' callback: 0 is not a positive integer/, + 'got error for bad pos int (0)' + ); +} + +{ + my $e = _test_args( + pos_int => 'bar', + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("bar") to main::validate1 did not pass the 'pos_int' callback: bar is not a positive integer/, + 'got error for bad pos int (bar)' + ); +} + +{ + my $e = do { + local $@; + eval { validate2( string => [] ); }; + $@; + }; + + is_deeply( + $e, + { error => 'not a string' }, + 'ref thrown by callback is preserved, not stringified' + ); +} + +sub _test_args { + local $@; + eval { validate1(@_) }; + return $@; +} + +sub validate1 { + validate( + @_, { + pos_int => { + callbacks => { + pos_int => sub { + $_[0] =~ /^[1-9][0-9]*$/ + or die "$_[0] is not a positive integer\n"; + }, + }, + }, + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die "$_[0] is not a string\n"; + }, + }, + }, + } + ); +} + +sub validate2 { + validate( + @_, { + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die { error => 'not a string' }; + }, + }, + }, + } + ); +} + +done_testing(); + diff --git a/t/release-pp-is-loaded.t b/t/release-pp-is-loaded.t new file mode 100644 index 0000000..1736ced --- /dev/null +++ b/t/release-pp-is-loaded.t @@ -0,0 +1,28 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PV_TEST_PERL} = 1; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Module::Implementation 0.04 (); +use Params::Validate; + +is( + Module::Implementation::implementation_for('Params::Validate'), + 'PP', + 'PP implementation is loaded when env var is set' +); + +done_testing(); diff --git a/t/release-synopsis.t b/t/release-synopsis.t new file mode 100644 index 0000000..2d9b8ee --- /dev/null +++ b/t/release-synopsis.t @@ -0,0 +1,13 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use Test::Synopsis; + +all_synopsis_ok(); diff --git a/t/release-xs-is-loaded.t b/t/release-xs-is-loaded.t new file mode 100644 index 0000000..bebb130 --- /dev/null +++ b/t/release-xs-is-loaded.t @@ -0,0 +1,25 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1 } + +use Module::Implementation 0.04 (); +use Params::Validate; + +is( + Module::Implementation::implementation_for('Params::Validate'), + 'XS', + 'XS implementation is loaded by default' +); + +done_testing(); diff --git a/t/release-xs-segfault.t b/t/release-xs-segfault.t new file mode 100644 index 0000000..892ab2c --- /dev/null +++ b/t/release-xs-segfault.t @@ -0,0 +1,34 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS'; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Params::Validate qw( validate SCALAR ); + +eval { foo( { a => 1 } ) }; + +ok(1, 'did not segfault'); + +done_testing(); + +sub foo { + validate( + @_, + { + a => { type => SCALAR, depends => ['%s%s%s'] }, + } + ); +} diff --git a/t/release-xs-stack-realloc.t b/t/release-xs-stack-realloc.t new file mode 100644 index 0000000..3441157 --- /dev/null +++ b/t/release-xs-stack-realloc.t @@ -0,0 +1,60 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS'; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Params::Validate qw( validate_with ); + +my $alloc_size; +for my $i ( 0 .. 15 ) { + $alloc_size = 2**$i; + test_array_spec(undef); +} + +ok( 1, 'array validation succeeded with stack realloc' ); + +for my $i ( 0 .. 15 ) { + $alloc_size = 2**$i; + test_hash_spec( a => undef ); +} + +ok( 1, 'hash validation succeeded with stack realloc' ); + +done_testing(); + +sub grow_stack { + my @stuff = (1) x $alloc_size; + + # "validation" always succeeds - we just need the stack to grow inside a + # callback to trigger the bug. + return 1; +} + +sub test_array_spec { + my @args = validate_with( + params => \@_, + spec => [ { callbacks => { grow_stack => \&grow_stack } } ], + ); +} + +sub test_hash_spec { + my %args = validate_with( + params => \@_, + spec => { + a => { callbacks => { grow_stack => \&grow_stack } }, + }, + ); +} |