t/constraints.t

   1 BEGIN {
   2         use strict;
   3         use warnings;
   4         use Test::More tests=>25;
   5         use Test::Exception;
   6 }
   7
   8 {
   9     package Test::MooseX::Meta::TypeConstraint::Structured;
  10
  11     use Moose;
  12     use Moose::Util::TypeConstraints;
  13     use MooseX::Meta::TypeConstraint::Structured::Named;
  14     use MooseX::Meta::TypeConstraint::Structured::Positional;
  15
  16     subtype 'MyString',
  17      as 'Str',
  18      where { $_=~m/abc/};
  19
  20     sub Tuple {
  21         my ($args, $optional) = @_;
  22         my @args = @$args;
  23         my @optional = ref $optional eq 'ARRAY' ? @$optional : ();
  24
  25         return MooseX::Meta::TypeConstraint::Structured::Positional->new(
  26             name => 'Tuple',
  27             parent => find_type_constraint('ArrayRef'),
  28             package_defined_in => __PACKAGE__,
  29             signature => [map {
  30                                 _normalize_type_constraint($_);
  31                         } @args],
  32         );
  33     }
  34
  35     sub Dict {
  36         my ($args, $optional) = @_;
  37         my %args = @$args;
  38         my %optional = ref $optional eq 'HASH' ? @$optional : ();
  39
  40         return MooseX::Meta::TypeConstraint::Structured::Named->new(
  41             name => 'Dict',
  42             parent => find_type_constraint('HashRef'),
  43             package_defined_in => __PACKAGE__,
  44             signature => {map {
  45                                 $_ => _normalize_type_constraint($args{$_});
  46                         } keys %args},
  47         );
  48     }
  49
  50         sub _normalize_type_constraint {
  51                 my $tc = shift @_;
  52                 if($tc && blessed $tc && $tc->isa('Moose::Meta::TypeConstraint')) {
  53                         return $tc;
  54                 } elsif($tc) {
  55                         return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc);
  56                 }
  57         }
  58
  59     has 'tuple' => (is=>'rw', isa=>Tuple['Int', 'Str', 'MyString']);
  60     has 'dict' => (is=>'rw', isa=>Dict[name=>'Str', age=>'Int']);
  61     has 'dict_with_maybe' => (is=>'rw', isa=>Dict[name=>'Str', age=>'Maybe[Int]']);
  62         has 'tuple_with_param' => (is=>'rw', isa=>Tuple['Int', 'Str', 'ArrayRef[Int]']);
  63         has 'tuple_with_maybe' => (is=>'rw', isa=>Tuple['Int', 'Str', 'Maybe[Int]']);
  64         has 'dict_with_tuple' => (is=>'rw', isa=>Dict[key1=>'Str', key2=>Tuple['Int','Str']]);
  65 }
  66
  67 ## Instantiate a new test object
  68
  69 ok my $record = Test::MooseX::Meta::TypeConstraint::Structured->new
  70  => 'Instantiated new Record test class.';
  71
  72 isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured'
  73  => 'Created correct object type.';
  74
  75 ## Test Tuple type constraint
  76
  77 lives_ok sub {
  78     $record->tuple([1,'hello', 'test.abc.test']);
  79 } => 'Set tuple attribute without error';
  80
  81 is $record->tuple->[0], 1
  82  => 'correct set the tuple attribute index 0';
  83
  84 is $record->tuple->[1], 'hello'
  85  => 'correct set the tuple attribute index 1';
  86
  87 is $record->tuple->[2], 'test.abc.test'
  88  => 'correct set the tuple attribute index 2';
  89
  90 throws_ok sub {
  91     $record->tuple([1,'hello', 'test.xxx.test']);
  92 }, qr/Validation failed for 'MyString'/
  93  => 'Properly failed for bad value in custom type constraint';
  94
  95 throws_ok sub {
  96     $record->tuple(['asdasd',2, 'test.abc.test']);
  97 }, qr/Validation failed for 'Int'/
  98  => 'Got Expected Error for violating constraints';
  99
 100 ## Test the Dictionary type constraint
 101
 102 lives_ok sub {
 103     $record->dict({name=>'frith', age=>23});
 104 } => 'Set dict attribute without error';
 105
 106 is $record->dict->{name}, 'frith'
 107  => 'correct set the dict attribute name';
 108
 109 is $record->dict->{age}, 23
 110  => 'correct set the dict attribute age';
 111
 112 throws_ok sub {
 113     $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});
 114 }, qr/Validation failed for 'Str'/
 115  => 'Got Expected Error for bad value in dict';
 116
 117 ## Test tuple_with_maybe
 118
 119 lives_ok sub {
 120     $record->tuple_with_maybe([1,'hello', 1]);
 121 } => 'Set tuple attribute without error';
 122
 123 throws_ok sub {
 124     $record->tuple_with_maybe([1,'hello', 'a']);
 125 }, qr/Validation failed for 'Maybe\[Int\]'/
 126  => 'Properly failed for bad value parameterized constraint';
 127
 128 lives_ok sub {
 129     $record->tuple_with_maybe([1,'hello']);
 130 } => 'Set tuple attribute without error skipping optional parameter';
 131
 132 ## Test Tuple with parameterized type
 133
 134 lives_ok sub {
 135     $record->tuple_with_param([1,'hello', [1,2,3]]);
 136 } => 'Set tuple attribute without error';
 137
 138 throws_ok sub {
 139     $record->tuple_with_param([1,'hello', [qw/a b c/]]);
 140 }, qr/Validation failed for 'ArrayRef\[Int\]'/
 141  => 'Properly failed for bad value parameterized constraint';
 142
 143 ## Test dict_with_maybe
 144
 145 lives_ok sub {
 146     $record->dict_with_maybe({name=>'frith', age=>23});
 147 } => 'Set dict attribute without error';
 148
 149 is $record->dict_with_maybe->{name}, 'frith'
 150  => 'correct set the dict attribute name';
 151
 152 is $record->dict_with_maybe->{age}, 23
 153  => 'correct set the dict attribute age';
 154
 155 throws_ok sub {
 156     $record->dict_with_maybe({name=>[1,2,3], age=>'sdfsdfsd'});
 157 }, qr/Validation failed for 'Str'/
 158  => 'Got Expected Error for bad value in dict';
 159
 160 throws_ok sub {
 161     $record->dict_with_maybe({age=>30});
 162 }, qr/Validation failed for 'Str'/
 163  => 'Got Expected Error for missing named parameter';
 164
 165 lives_ok sub {
 166     $record->dict_with_maybe({name=>'usal'});
 167 } => 'Set dict attribute without error, skipping optional';
 168
 169 ## Test dict_with_tuple
 170
 171 lives_ok sub {
 172     $record->dict_with_tuple({key1=>'Hello', key2=>[1,'World']});
 173 } => 'Set tuple attribute without error';
 174
 175 throws_ok sub {
 176     $record->dict_with_tuple({key1=>'Hello', key2=>['World',2]});
 177 }, qr/Validation failed for 'Int'/
 178  => 'Threw error on bad constraint';
 179
 180
 181