t/023_moose_respects_type_constraints.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 9;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Moose');
  11     use_ok('Moose::Util::TypeConstraints');
  12 }
  13
  14 =pod
  15
  16 This tests demonstrates that Moose will not override
  17 a pre-existing type constraint of the same name when
  18 making constraints for a Moose-class.
  19
  20 It also tests that an attribute which uses a 'Foo' for
  21 it's isa option will get the subtype Foo, and not a
  22 type representing the Foo moose class.
  23
  24 =cut
  25
  26 BEGIN {
  27     # create this subtype first (in BEGIN)
  28     subtype Foo
  29         => as 'Value'
  30         => where { $_ eq 'Foo' };
  31 }
  32
  33 { # now seee if Moose will override it
  34     package Foo;
  35     use strict;
  36     use warnings;
  37     use Moose;
  38 }
  39
  40 my $foo_constraint = find_type_constraint('Foo');
  41 isa_ok($foo_constraint, 'Moose::Meta::TypeConstraint');
  42
  43 is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo');
  44
  45 ok($foo_constraint->check('Foo'), '... my constraint passed correctly');
  46 ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly');
  47
  48 {
  49     package Bar;
  50     use strict;
  51     use warnings;
  52     use Moose;
  53
  54     has 'foo' => (is => 'rw', isa => 'Foo');
  55 }
  56
  57 my $bar = Bar->new;
  58 isa_ok($bar, 'Bar');
  59
  60 lives_ok {
  61     $bar->foo('Foo');
  62 } '... checked the type constraint correctly';
  63
  64 dies_ok {
  65     $bar->foo(Foo->new);
  66 } '... checked the type constraint correctly';
  67
  68
  69