t/05-advanced.t

   1 BEGIN {
   2         use strict;
   3         use warnings;
   4         use Test::More tests=>16;
   5         use Test::Exception;
   6 }
   7
   8 {
   9     package Test::MooseX::Meta::TypeConstraint::Structured::Advanced;
  10
  11     use Moose;
  12     use MooseX::Types::Structured qw(Dict Tuple);
  13         use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe);
  14         use MooseX::Types -declare => [qw(
  15         EqualLength MoreThanFive MoreLengthPlease PersonalInfo MorePersonalInfo
  16         MinFiveChars
  17     )];
  18
  19     subtype MoreThanFive,
  20      as Int,
  21      where { $_ > 5};
  22
  23     ## Tuple contains two equal length Arrays
  24     subtype EqualLength,
  25      as Tuple[ArrayRef[MoreThanFive],ArrayRef[MoreThanFive]],
  26      where { $#{$_->[0]} == $#{$_->[1]} };
  27
  28     ## subclass the complex tuple
  29     subtype MoreLengthPlease,
  30      as EqualLength,
  31      where { $#{$_->[0]} >= 4};
  32
  33     ## Complexe Dict
  34     subtype PersonalInfo,
  35      as Dict[name=>Str, stats=>MoreLengthPlease|Object];
  36
  37     ## Minimum 5 char string
  38     subtype MinFiveChars,
  39      as Str,
  40      where { length($_) > 5};
  41
  42     ## Dict key overloading
  43     subtype MorePersonalInfo,
  44     # as PersonalInfo[name=>MinFiveChars];
  45      as PersonalInfo;
  46
  47     has 'EqualLengthAttr' => (is=>'rw', isa=>EqualLength);
  48     has 'MoreLengthPleaseAttr' => (is=>'rw', isa=>MoreLengthPlease);
  49     has 'PersonalInfoAttr' => (is=>'rw', isa=>PersonalInfo);
  50     has 'MorePersonalInfo' => (is=>'rw', isa=>MorePersonalInfo);
  51 }
  52
  53 ## Instantiate a new test object
  54
  55 ok my $obj = Test::MooseX::Meta::TypeConstraint::Structured::Advanced->new
  56  => 'Instantiated new Record test class.';
  57
  58 isa_ok $obj => 'Test::MooseX::Meta::TypeConstraint::Structured::Advanced'
  59  => 'Created correct object type.';
  60
  61 ## Test EqualLengthAttr
  62
  63 lives_ok sub {
  64     $obj->EqualLengthAttr([[6,7,8],[9,10,11]]);
  65 } => 'Set EqualLengthAttr attribute without error';
  66
  67 throws_ok sub {
  68     $obj->EqualLengthAttr([1,'hello', 'test.xxx.test']);
  69 }, qr/Attribute \(EqualLengthAttr\) does not pass the type constraint/
  70  => q{EqualLengthAttr correctly fails [1,'hello', 'test.xxx.test']};
  71
  72 throws_ok sub {
  73     $obj->EqualLengthAttr([[6,7],[9,10,11]]);
  74 }, qr/Attribute \(EqualLengthAttr\) does not pass the type constraint/
  75  => q{EqualLengthAttr correctly fails [[6,7],[9,10,11]]};
  76
  77 throws_ok sub {
  78     $obj->EqualLengthAttr([[6,7,1],[9,10,11]]);
  79 }, qr/Attribute \(EqualLengthAttr\) does not pass the type constraint/
  80  => q{EqualLengthAttr correctly fails [[6,7,1],[9,10,11]]};
  81
  82 ## Test MoreLengthPleaseAttr
  83
  84 lives_ok sub {
  85     $obj->MoreLengthPleaseAttr([[6,7,8,9,10],[11,12,13,14,15]]);
  86 } => 'Set MoreLengthPleaseAttr attribute without error';
  87
  88 throws_ok sub {
  89     $obj->MoreLengthPleaseAttr([[6,7,8,9],[11,12,13,14]]);
  90 }, qr/Attribute \(MoreLengthPleaseAttr\) does not pass the type constraint/
  91  => q{MoreLengthPleaseAttr correctly fails [[6,7,8,9],[11,12,13,14]]};
  92
  93 ## Test PersonalInfoAttr
  94
  95 lives_ok sub {
  96     $obj->PersonalInfoAttr({name=>'John', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
  97 } => 'Set PersonalInfoAttr attribute without error 1';
  98
  99 lives_ok sub {
 100     $obj->PersonalInfoAttr({name=>'John', stats=>$obj});
 101 } => 'Set PersonalInfoAttr attribute without error 2';
 102
 103 throws_ok sub {
 104     $obj->PersonalInfoAttr({name=>'John', stats=>[[6,7,8,9],[11,12,13,14]]});
 105 }, qr/Attribute \(PersonalInfoAttr\) does not pass the type constraint/
 106  => q{PersonalInfoAttr correctly fails name=>'John', stats=>[[6,7,8,9],[11,12,13,14]]};
 107
 108 throws_ok sub {
 109     $obj->PersonalInfoAttr({name=>'John', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
 110 }, qr/Attribute \(PersonalInfoAttr\) does not pass the type constraint/
 111  => q{PersonalInfoAttr correctly fails name=>'John', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
 112
 113 ## Test MorePersonalInfo
 114
 115 lives_ok sub {
 116     $obj->MorePersonalInfo({name=>'Johnnap', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
 117 } => 'Set MorePersonalInfo attribute without error 1';
 118
 119 throws_ok sub {
 120     $obj->MorePersonalInfo({name=>'Johnnap', stats=>[[6,7,8,9],[11,12,13,14]]});
 121 }, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
 122  => q{MorePersonalInfo correctly fails name=>'Johnnap', stats=>[[6,7,8,9],[11,12,13,14]]};
 123
 124 throws_ok sub {
 125     $obj->MorePersonalInfo({name=>'Johnnap', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
 126 }, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
 127  => q{MorePersonalInfo correctly fails name=>'Johnnap', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
 128
 129 SKIP: {
 130     skip 'not yet working', 1;
 131
 132     throws_ok sub {
 133         $obj->MorePersonalInfo({name=>'abc', stats=>[[6,7,8,9,10],[11,12,13,14,15]]});
 134     }, qr/Attribute \(MorePersonalInfo\) does not pass the type constraint/
 135      => q{MorePersonalInfo correctly fails name=>'aaa', extra=>1, stats=>[[6,7,8,9,10],[11,12,13,14,15]]};
 136 }
 137