Badger

 view release on metacpan or  search on metacpan

lib/Badger/Data/Facet/Class.pm  view on Meta::CPAN

use Carp;
use Badger::Data::Facets;
use Badger::Class
    version    => 0.01,
    debug      => 0,
    uber       => 'Badger::Class',
    utils      => 'camel_case',
    constants  => 'DELIMITER ARRAY',
    constant   => {
        FACETS => 'Badger::Data::Facets',
        FACET  => 'Badger::Data::Facet',
    },
    hooks      => {
        type   => \&type,
        args   => \&args,
        opts   => \&opts,
    };


sub type {
    my ($self, $type) = @_;
    my $facet = $self->FACETS->prototype->find($type)
        || croak "Invalid facet type: $type\n";
    $self->base($facet);
}


sub args {
    my ($self, $args) = @_;
    
    $args = [ split(DELIMITER, $args) ]
        unless ref $args eq ARRAY;

lib/Badger/Data/Type.pm  view on Meta::CPAN

    import    => 'CLASS',
    accessors => 'base namespace facets',
    constants => 'CODE DOT',
    as_text   => 'name',
    is_true   => 1,
    constant  => {
        type    => '',
        simple  => 0,
        complex => 0,
#       CLAUSES => 'Badger::Data::Clauses',
        FACETS  => 'Badger::Data::Facets',
    },
    alias     => {
        init  => \&init_type,
    };

use Badger::Debug ':dump';

our @PARAMS = qw( base name namespace );


sub init_type {
    my ($self, $config) = @_;

    # copy in basic parameters
    @$self{ @PARAMS } = @$config{ @PARAMS };

    # constraint the type with any validation facets defined
    $self->constrain( 
        $self->class->list_vars( FACETS => $config->{ facets } )
    );
    return $self;
}


sub name {
    my $self = shift;
    return $self->{ name } ||= do {
        my $pkg  = ref $self || $self;
        my $base = CLASS;
        $pkg =~ s/${base}:://g;
        $pkg =~ s/::/./g;
        $pkg;
    };
}


sub constrain {
    my ($self, @args) = @_;
    my $FACETS = $self->FACETS;
    my $facets = $self->{ facets } ||= [ ];
    my $type   = $self->type;
    my ($name, $value);

    $self->debug("preparing facets: ", $self->dump_data($facets)) if DEBUG;

    while (@args) {
        $name = shift(@args);
        $self->debug("preparing facet: $name") if DEBUG;
        push(
            @$facets, 
            ref $name eq CODE 
                ? $name
                : $FACETS->facet(
                      # prepend the basic type (e.g. length => text.length)
                      # unless type and facet are the same (e.g. text => text)
                      ($type eq $name) ? $type : ($type ? $type.DOT.$name : $name),
                      shift(@args)
                  )
        );
    }

    $self->debug("constrained type with facets: ", $self->dump_data($facets), "\n")
        if DEBUG;

lib/Badger/Data/Type/Class.pm  view on Meta::CPAN

package Badger::Data::Type::Class;

use Badger::Debug ':dump';
use Badger::Class
    version    => 0.01,
    debug      => 0,
    uber       => 'Badger::Class',
#    words      => 'FACETS',
    constants  => 'ARRAY DELIMITER',
    hooks      => {
        type   => \&type,
        size   => \&size,
        facets => \&facets,
    };


sub type {
    my ($self, $type) = @_;

lib/Badger/Data/Type/Class.pm  view on Meta::CPAN

sub size {
    my ($self, $size) = @_;
    $self->debug("set size to $size") if DEBUG;
    $self->method( size => $size );
}


sub facets {
    my ($self, $facets) = @_;
    my $current = $self->var_default( FACETS => [ ] );

    foreach ($facets, $current) {
        $_ = [ split DELIMITER ]
            unless ref eq ARRAY;
    }

    push(@$current, @$facets);
    
    $self->debug("merged facets are ", $self->dump_data($facets)) if DEBUG;
    
    $self->var( FACETS => $current );
}


1;

=head1 NAME

Badger::Data::Type::Class - metaprogramming module for data type classes

=head1 SYNOPSIS

t/data/facets.t  view on Meta::CPAN

#========================================================================

use lib qw( ./lib ../lib ../../lib );

use Badger::Test 
    tests => 1,
    debug => 'Badger::Data::Type::Simple',
    args  => \@ARGV;

use Badger::Data::Facets;
use constant FACETS => 'Badger::Data::Facets';

pass('loaded Badger::Data::Facets');

t/data/list_facets.t  view on Meta::CPAN

#use Badger::Debug
#    modules => 'Badger::Factory';
    
use Badger::Test 
    tests => 20,
    debug => 'Badger::Data::Facet::List',
    args  => \@ARGV;

use Badger::Data::Facets;
use constant FACETS => 'Badger::Data::Facets';


#-----------------------------------------------------------------------
# size
#-----------------------------------------------------------------------

my $size = FACETS->facet( 'list.size' => 23 );
ok( $size, 'got size facet from number' );
is( $size->size, 23, 'got size facet with value 23' );

$size = FACETS->facet( 'list.size' => { size => 6 } );
ok( $size, 'got size facet from hash ref' );
is( $size->size, 6, 'got size facet with value 6' );

ok( $size->validate([1..6]), 'list is 6 element long' );
ok( ! $size->try( validate => [1..5] ), 'list is only 5 elements long' );
is( $size->reason->type, 
    'data.facet.list.size',
    'got short size error message' 
);
is( $size->reason->info, 
    'List should have 6 elements (got 5)', 
    'got short list error message' 
);


#-----------------------------------------------------------------------
# min_size
#-----------------------------------------------------------------------

$size = FACETS->facet( 'list.min_size' => 3 );
ok( $size, 'got list.min_size facet' );

$size = FACETS->facet( list_min_size => { min_size => 3 } );
ok( $size, 'got list_min_size facet' );

ok( ! $size->try( validate => [1] ), 'min size fail on 1 list element' );
is( $size->reason->info, 'List should have at least 3 elements (got 1)', 'min size list reason' );
ok( $size->validate([10,20,30]), 'min size on 3 list elements' );
ok( $size->validate([11,21,31,41,51,61]), 'min size on 6 list elements' );



#-----------------------------------------------------------------------
# max_size
#-----------------------------------------------------------------------

$size = FACETS->facet( 'list.max_size' => 3 );
ok( $size, 'got list.max_size facet' );

$size = FACETS->facet( list_max_size => { max_size => 3 } );
ok( $size, 'got list_max_size facet' );

ok( ! $size->try( validate => [1,2,3,4] ), 'max size fail on 4 list elements' );
is( $size->reason->info, 'List should have at most 3 elements (got 4)', 'max size list reason' );
ok( $size->validate([10,20,30]), 'max size on 3 list elements' );
ok( $size->validate([11,21]), 'max size on 2 list elements' );



__END__
#-----------------------------------------------------------------------
# pattern
#-----------------------------------------------------------------------

my $pattern = FACETS->facet( pattern => '^\w+$' );
ok( $pattern, 'got pattern facet' );
ok( ! $pattern->try( validate => 'Hello World!' ), 'pattern fail on 2 words' );
is( $pattern->reason->info, 'Text does not match pattern: ^\w+$', 'pattern fail reason' );
ok( $pattern->validate('foo'), 'pattern match on foo' );


#-----------------------------------------------------------------------
# any
#-----------------------------------------------------------------------

my $any = FACETS->facet( any => ['foo', 'bar'] );
ok( $any, 'got any facet' );
ok( ! $any->try( validate => 'baz' ), 'any fail on baz' );
is( $any->reason->info, 'Text does not match any of the permitted values: baz', 'any fail reason' );
ok( $any->validate('foo'), 'any match on foo' );


#-----------------------------------------------------------------------
# whitespace
#-----------------------------------------------------------------------

my $fold = FACETS->facet( whitespace => 'fold' );
ok( $fold, 'got whitespace folding facet' );
my $text = $fold->validate("Hello\nWorld!");
is( $text, 'Hello World!', 'folded whitespace' );

my $collapse = FACETS->facet( whitespace => 'collapse' );
ok( $collapse, 'got whitespace collapsing facet' );
$text = $collapse->validate("   \n\nHello\n\n\nBadger!\n\n\  ");
is( $text, 'Hello Badger!', 'collapsed whitespace' );

t/data/text_facets.t  view on Meta::CPAN

#use Badger::Debug
#    modules => 'Badger::Factory';
    
use Badger::Test 
    tests => 30,
    debug => 'Badger::Data::Facet::Text',
    args  => \@ARGV;

use Badger::Data::Facets;
use constant FACETS => 'Badger::Data::Facets';


#-----------------------------------------------------------------------
# length
#-----------------------------------------------------------------------

my $length = FACETS->facet( 'text.length' => 23 );
ok( $length, 'got text.length facet from number' );
is( $length->length, 23, 'got length facet with value 23' );

$length = FACETS->facet( text_length => { length => 6 } );
ok( $length, 'got text_length facet from hash ref' );
is( $length->length, 6, 'got length facet with value 6' );

my $text = 'abcdef';
ok( $length->validate(\$text), 'text is 6 characters long' );

$text = 'abcde';
ok( ! $length->try( validate => \$text ), 'text is only 5 characters long' );
is( $length->reason->type, 
    'data.facet.text.length',

t/data/text_facets.t  view on Meta::CPAN

is( $length->reason->info, 
    'Text should be 6 characters long (got 5)', 
    'got short text error message' 
);


#-----------------------------------------------------------------------
# min_length
#-----------------------------------------------------------------------

$length = FACETS->facet( 'text.min_length' => 3 );
ok( $length, 'got text.min_length facet' );

$length = FACETS->facet( text_min_length => 3 );
ok( $length, 'got text_min_length facet' );

$text = 'ab';
ok( ! $length->try( validate => \$text ), 'min length fail on 2 characters' );
is( $length->reason->info, 'Text should be at least 3 characters long (got 2)', 'min length text reason' );

$text = 'abc';
ok( $length->validate(\$text), 'min length on 3 characters' );

$text = 'abcdef';
ok( $length->validate(\$text), 'min length on 6 characters' );


#-----------------------------------------------------------------------
# max_length
#-----------------------------------------------------------------------

$length = FACETS->facet( 'text.max_length' => 3 );
ok( $length, 'got text.max_length facet' );

$length = FACETS->facet( text_max_length => { max_length => 3 } );
ok( $length, 'got text_max_length facet' );

$text = 'abcd';
ok( ! $length->try( validate => \$text ), 'max length fail on 4 characters' );
is( $length->reason->info, 'Text should be at most 3 characters long (got 4)', 'max length text reason' );

$text = 'abc';
ok( $length->validate(\$text), 'max length on 3 characters' );

$text = 'ab';
ok( $length->validate(\$text), 'max length on 2 characters' );


#-----------------------------------------------------------------------
# pattern
#-----------------------------------------------------------------------

my $pattern = FACETS->facet( 'text.pattern' => '^\w+$' );
ok( $pattern, 'got pattern facet' );

$text = 'Hello World!';
ok( ! $pattern->try( validate => \$text ), 'pattern fail on 2 words' );
is( $pattern->reason->info, 'Text does not match pattern: ^\w+$', 'pattern fail reason' );

$text = 'foo';
ok( $pattern->validate(\$text), 'pattern match on foo' );


#-----------------------------------------------------------------------
# whitespace
#-----------------------------------------------------------------------

my $fold = FACETS->facet( 'text.whitespace' => 'fold' );
ok( $fold, 'got whitespace folding facet' );

$text = "Hello\nWorld!";
ok( $fold->validate(\$text), 'called whitespace folding facet' );
is( $text, 'Hello World!', 'folded whitespace' );

my $collapse = FACETS->facet( 'text.whitespace' => 'collapse' );
ok( $collapse, 'got whitespace collapsing facet' );

$text = "   \n\nHello\n\n\nBadger!\n\n\  ";
ok( $collapse->validate(\$text), 'called whitespace collapsing facet' );
is( $text, 'Hello Badger!', 'collapsed whitespace' );



__END__


#-----------------------------------------------------------------------
# any
#-----------------------------------------------------------------------

my $any = FACETS->facet( any => ['foo', 'bar'] );
ok( $any, 'got any facet' );
ok( ! $any->try( validate => 'baz' ), 'any fail on baz' );
is( $any->reason->info, 'Text does not match any of the permitted values: baz', 'any fail reason' );
ok( $any->validate('foo'), 'any match on foo' );