t/040_type_constraints/failing/030_class_subtypes.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 26;
   7 use Test::Exception;
   8
   9 use Mouse::Util::TypeConstraints;
  10 use Mouse::Meta::TypeConstraint;
  11
  12
  13 ## Create a subclass with a custom method
  14
  15 {
  16     package Test::Mouse::Meta::TypeConstraint::AnySubType;
  17     use Mouse;
  18     extends 'Mouse::Meta::TypeConstraint';
  19
  20     sub my_custom_method {
  21         return 1;
  22     }
  23 }
  24
  25 my $Int = find_type_constraint('Int');
  26 ok $Int, 'Got a good type contstraint';
  27
  28 my $parent  = Test::Mouse::Meta::TypeConstraint::AnySubType->new({
  29                 name => "Test::Mouse::Meta::TypeConstraint::AnySubType" ,
  30                 parent => $Int,
  31 });
  32
  33 ok $parent, 'Created type constraint';
  34 ok $parent->check(1), 'Correctly passed';
  35 ok ! $parent->check('a'), 'correctly failed';
  36 ok $parent->my_custom_method, 'found the custom method';
  37
  38 my $subtype1 = subtype 'another_subtype' => as $parent;
  39
  40 ok $subtype1, 'Created type constraint';
  41 ok $subtype1->check(1), 'Correctly passed';
  42 ok ! $subtype1->check('a'), 'correctly failed';
  43 ok $subtype1->my_custom_method, 'found the custom method';
  44
  45
  46 my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 };
  47
  48 ok $subtype2, 'Created type constraint';
  49 ok $subtype2->check(1), 'Correctly passed';
  50 ok ! $subtype2->check('a'), 'correctly failed';
  51 ok ! $subtype2->check(100), 'correctly failed';
  52
  53 ok $subtype2->my_custom_method, 'found the custom method';
  54
  55
  56 {
  57     package Foo;
  58
  59     use Mouse;
  60 }
  61
  62 {
  63     package Bar;
  64
  65     use Mouse;
  66
  67     extends 'Foo';
  68 }
  69
  70 {
  71     package Baz;
  72
  73     use Mouse;
  74 }
  75
  76 my $foo = class_type 'Foo';
  77 my $isa_foo = subtype 'IsaFoo' => as $foo;
  78
  79 ok $isa_foo, 'Created subtype of Foo type';
  80 ok $isa_foo->check( Foo->new ), 'Foo passes check';
  81 ok $isa_foo->check( Bar->new ), 'Bar passes check';
  82 ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check';
  83 like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' failed with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message';
  84
  85 # Maybe in the future this *should* inherit?
  86 like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' failed with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message";
  87
  88
  89 # Implicit types
  90 {
  91     package Quux;
  92
  93     use Mouse;
  94
  95     has age => (
  96         isa => 'Positive',
  97         is => 'bare',
  98     );
  99 }
 100
 101 throws_ok {
 102     Quux->new(age => 3)
 103 } qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/;
 104
 105 lives_ok {
 106     Quux->new(age => (bless {}, 'Positive'));
 107 };
 108
 109 eval "
 110     package Positive;
 111     use Mouse;
 112 ";
 113
 114 throws_ok {
 115     Quux->new(age => 3)
 116 } qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/;
 117
 118 lives_ok {
 119     Quux->new(age => Positive->new)
 120 };
 121
 122 class_type 'Negative' => message { "$_ is not a Negative Nancy" };
 123
 124 {
 125     package Quux::Ier;
 126
 127     use Mouse;
 128
 129     has age => (
 130         isa => 'Negative',
 131         is => 'bare',
 132     );
 133 }
 134
 135 throws_ok {
 136     Quux::Ier->new(age => 3)
 137 } qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy /;
 138
 139 lives_ok {
 140     Quux::Ier->new(age => (bless {}, 'Negative'))
 141 };