t/001_mouse/039-subtype.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 14;
   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 ok(My::Class->new(name => 'foo'));
  30
  31 throws_ok { My::Class->new(name => '') } qr/^Attribute \(name\) does not pass the type constraint because: The string is empty!/;
  32
  33 my $st = subtype as 'Str', where{ length };
  34
  35 ok $st->is_a_type_of('Str');
  36 ok!$st->is_a_type_of('NoemptyStr');
  37
  38 ok $st->check('Foo');
  39 ok!$st->check(undef);
  40 ok!$st->check('');
  41
  42 lives_and{
  43     my $tc = find_type_constraint('MyClass');
  44     ok $tc->check(My::Class->new());
  45     ok!$tc->check('My::Class');
  46     ok!$tc->check([]);
  47     ok!$tc->check(undef);
  48 };
  49
  50 package Foo;
  51 use Mouse::Util::TypeConstraints;
  52
  53 $st = subtype as 'Int', where{ $_ > 0 };
  54
  55 ::ok $st->is_a_type_of('Int');
  56 ::ok $st->check(10);
  57 ::ok!$st->check(0);
  58