callbacks.pl   [plain text]

use strict;

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;
}

package main;

use Test;

BEGIN { plan test => 3 }

my %allowed = ( foo => 1, baz => 1 );
eval
{
    my @a = ( foo => 'foo' );
    validate( @a, { foo => { callbacks =>
                             { is_allowed => sub { $allowed{ lc $_[0] } } },
                           }
                  } );
};
ok( ! $@ );

eval
{
    my @a = ( foo => 'aksjgakl' );

    validate( @a, { foo => { callbacks =>
                             { is_allowed => sub { $allowed{ lc $_[0] } } },
                           }
                  } );
};
ok( $ENV{PERL_NO_VALIDATION} ? ! $@ :
    $@ =~ /is_allowed/ );

# duplicates code from Lingua::ZH::CCDICT that revelead bug fixed in
# 0.56.
eval
{
    Foo->new( storage => 'InMemory', file => 'something' );
};
ok( ! $@ );



1;