t/010_basics/011_moose_respects_type_constraints.t

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