t/040_type_constraints/failing/021_maybe_type_constraint.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 36;
   7 use Test::Exception;
   8
   9 use Mouse::Util::TypeConstraints;
  10
  11 my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]');
  12 isa_ok($type, 'Mouse::Meta::TypeConstraint');
  13 isa_ok($type, 'Mouse::Meta::TypeConstraint::Parameterized');
  14
  15 ok( $type->equals($type), "equals self" );
  16 ok( !$type->equals($type->parent), "not equal to parent" );
  17 ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" );
  18 ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" );
  19 ok( $type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
  20 ok( !$type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
  21 ok( !$type->equals( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
  22
  23 ok($type->check(10), '... checked type correctly (pass)');
  24 ok($type->check(undef), '... checked type correctly (pass)');
  25 ok(!$type->check('Hello World'), '... checked type correctly (fail)');
  26 ok(!$type->check([]), '... checked type correctly (fail)');
  27
  28 {
  29     package Bar;
  30     use Mouse;
  31
  32     package Foo;
  33     use Mouse;
  34     use Mouse::Util::TypeConstraints;
  35
  36     has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1);
  37     has 'bar' => (is => 'rw', isa => class_type('Bar'));
  38     has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar')));
  39 }
  40
  41 lives_ok {
  42     Foo->new(arr => [], bar => Bar->new);
  43 } '... Bar->new isa Bar';
  44
  45 dies_ok {
  46     Foo->new(arr => [], bar => undef);
  47 } '... undef isnta Bar';
  48
  49 lives_ok {
  50     Foo->new(arr => [], maybe_bar => Bar->new);
  51 } '... Bar->new isa maybe(Bar)';
  52
  53 lives_ok {
  54     Foo->new(arr => [], maybe_bar => undef);
  55 } '... undef isa maybe(Bar)';
  56
  57 dies_ok {
  58     Foo->new(arr => [], maybe_bar => 1);
  59 } '... 1 isnta maybe(Bar)';
  60
  61 lives_ok {
  62     Foo->new(arr => []);
  63 } '... it worked!';
  64
  65 lives_ok {
  66     Foo->new(arr => undef);
  67 } '... it worked!';
  68
  69 dies_ok {
  70     Foo->new(arr => 100);
  71 } '... failed the type check';
  72
  73 dies_ok {
  74     Foo->new(arr => 'hello world');
  75 } '... failed the type check';
  76
  77
  78 {
  79     package Test::MouseX::Types::Maybe;
  80     use Mouse;
  81
  82     has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]');
  83     has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]');
  84     has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]');
  85     has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]');
  86     has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]');
  87 }
  88
  89 ok my $obj = Test::MouseX::Types::Maybe->new
  90  => 'Create good test object';
  91
  92 ##  Maybe[Int]
  93
  94 ok my $Maybe_Int  = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]')
  95  => 'made TC Maybe[Int]';
  96
  97 ok $Maybe_Int->check(1)
  98  => 'passed (1)';
  99
 100 ok $obj->Maybe_Int(1)
 101  => 'assigned (1)';
 102
 103 ok $Maybe_Int->check()
 104  => 'passed ()';
 105
 106 ok $obj->Maybe_Int()
 107  => 'assigned ()';
 108
 109 ok $Maybe_Int->check(0)
 110  => 'passed (0)';
 111
 112 ok defined $obj->Maybe_Int(0)
 113  => 'assigned (0)';
 114
 115 ok $Maybe_Int->check(undef)
 116  => 'passed (undef)';
 117
 118 ok sub {$obj->Maybe_Int(undef); 1}->()
 119  => 'assigned (undef)';
 120
 121 ok !$Maybe_Int->check("")
 122  => 'failed ("")';
 123
 124 throws_ok sub { $obj->Maybe_Int("") },
 125  qr/Attribute \(Maybe_Int\) does not pass the type constraint/
 126  => 'failed assigned ("")';
 127
 128 ok !$Maybe_Int->check("a")
 129  => 'failed ("a")';
 130
 131 throws_ok sub { $obj->Maybe_Int("a") },
 132  qr/Attribute \(Maybe_Int\) does not pass the type constraint/
 133  => 'failed assigned ("a")';