t/concept.t

   1 BEGIN {
   2         use strict;
   3         use warnings;
   4         use Test::More tests=>17;
   5         use Test::Exception;
   6 }
   7
   8 {
   9     package Test::MooseX::Meta::TypeConstraint::Structured::Concept;
  10
  11     use Moose;
  12     use Moose::Util::TypeConstraints;
  13
  14     sub _normalize_args {
  15         if(defined $_[0] && ref $_[0] eq 'ARRAY') {
  16             return @{$_[0]};
  17         } else {
  18             confess 'Arguments not normal';
  19         }
  20     }
  21
  22     sub Pair {
  23         my ($canonical_key, $value) = _normalize_args(shift);
  24         return subtype
  25             as "HashRef[$value]",
  26             where {
  27                 my ($key, $extra) = keys %$_;
  28                 ($key eq $canonical_key) && !$extra;
  29             };
  30     }
  31
  32     sub Tuple {
  33         my @args = _normalize_args(shift);
  34         return subtype
  35          as 'ArrayRef',
  36          where {
  37             my @incoming = @$_;
  38             foreach my $idx (0..$#args) {
  39                 find_type_constraint($args[$idx])->check($incoming[$idx]) ||
  40                  confess 'Trouble validating Tuple';
  41             } 1;
  42          };
  43     }
  44
  45     sub Dict {
  46         my %keys_typeconstraints = _normalize_args(shift);
  47         return subtype
  48          as 'HashRef',
  49          where {
  50             my %incoming = %$_;
  51             foreach my $key (keys %keys_typeconstraints) {
  52                 my $type_constraint = $keys_typeconstraints{$key};
  53                 my $incoming = $incoming{$key} || confess "Missing $key";
  54                 find_type_constraint($type_constraint)->check($incoming)
  55                  || confess "Trouble validating Dictionary";
  56             } 1;
  57          };
  58     }
  59
  60     has 'pair' => (is=>'rw', isa=>Pair[key=>'Str']);
  61     has 'tuple' => (is=>'rw', isa=>Tuple['Int', 'Str']);
  62     has 'dict' => (is=>'rw', isa=>Dict[name=>'Str', age=>'Int']);
  63 }
  64
  65 ## Instantiate a new test object
  66
  67 ok my $record = Test::MooseX::Meta::TypeConstraint::Structured::Concept->new
  68  => 'Instantiated new Record test class.';
  69
  70 isa_ok $record => 'Test::MooseX::Meta::TypeConstraint::Structured::Concept'
  71  => 'Created correct object type.';
  72
  73 ## Test the Pair type constraint
  74
  75 lives_ok sub {
  76     $record->pair({key=>'value'});
  77 } => 'Set pair attribute without error';
  78
  79 is $record->pair->{key}, 'value'
  80  => 'correctly set the pair attribute';
  81
  82 throws_ok sub {
  83     $record->pair({not_the_key=>'value'}) ;
  84 }, qr/Validation failed/
  85  => 'Got Expected Error for bad key';
  86
  87 throws_ok sub {
  88     $record->pair({key=>[1,2,3]}) ;
  89 }, qr/Validation failed/
  90  => 'Got Expected Error for bad value';
  91
  92 ## Test the Tuple type constraint
  93
  94 lives_ok sub {
  95     $record->tuple([1,'hello']);
  96 } => 'Set tuple attribute without error';
  97
  98 is $record->tuple->[0], 1
  99  => 'correct set the tuple attribute index 0';
 100
 101 is $record->tuple->[1], 'hello'
 102  => 'correct set the tuple attribute index 1';
 103
 104 throws_ok sub {
 105     $record->tuple('hello') ;
 106 }, qr/Validation failed/
 107  => 'Got Expected Error when setting as a scalar';
 108
 109 throws_ok sub {
 110     $record->tuple({key=>[1,2,3]}) ;
 111 }, qr/Validation failed/
 112  => 'Got Expected Error for trying a hashref ';
 113
 114 throws_ok sub {
 115     $record->tuple(['asdasd',2]) ;
 116 }, qr/Trouble validating Tuple/
 117  => 'Got Expected Error for violating constraints';
 118
 119 ## Test the Dictionary type constraint
 120
 121 lives_ok sub {
 122     $record->dict({name=>'frith', age=>23});
 123 } => 'Set dict attribute without error';
 124
 125 is $record->dict->{name}, 'frith'
 126  => 'correct set the dict attribute name';
 127
 128 is $record->dict->{age}, 23
 129  => 'correct set the dict attribute age';
 130
 131 throws_ok sub {
 132     $record->dict('hello') ;
 133 }, qr/Validation failed/
 134  => 'Got Expected Error for bad key in dict';
 135
 136 throws_ok sub {
 137     $record->dict({name=>[1,2,3], age=>'sdfsdfsd'});
 138 }, qr/Trouble validating Dictionary/
 139  => 'Got Expected Error for bad value in dict';
 140