Moose-t-failing/040_type_constraints/030_class_subtypes.t

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