t/001_mouse/039-subtype.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 11;
   5 use Test::Exception;
   6
   7 use Mouse::Util::TypeConstraints;
   8
   9 do {
  10     package My::Class;
  11     use Mouse;
  12     use Mouse::Util::TypeConstraints;
  13
  14     subtype 'NonemptyStr'
  15         => as 'Str'
  16         => where { length $_ }
  17         => message { "The string is empty!" };
  18
  19     subtype 'MyClass'
  20         => as 'Object'
  21         => where { $_->isa(__PACKAGE__) };
  22
  23     has name => (
  24         is  => 'ro',
  25         isa => 'NonemptyStr',
  26     );
  27
  28
  29 };
  30
  31 ok(My::Class->new(name => 'foo'));
  32
  33 throws_ok { My::Class->new(name => '') } qr/^Attribute \(name\) does not pass the type constraint because: The string is empty!/;
  34
  35 my $st = subtype as 'Str', where{ length };
  36
  37 ok $st->is_a_type_of('Str');
  38 ok!$st->is_a_type_of('NoemptyStr');
  39
  40 ok $st->check('Foo');
  41 ok!$st->check(undef);
  42 ok!$st->check('');
  43
  44 lives_and{
  45     my $tc = find_type_constraint('MyClass');
  46     ok $tc->check(My::Class->new());
  47     ok!$tc->check('My::Class');
  48     ok!$tc->check([]);
  49     ok!$tc->check(undef);
  50 };