t/100_bugs/017_type_constraint_messages.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 3;
   7 use Test::Exception;
   8
   9
  10
  11 # RT #37569
  12
  13 {
  14     package MyObject;
  15     use Mouse;
  16
  17     package Foo;
  18     use Mouse;
  19     use Mouse::Util::TypeConstraints;
  20
  21     subtype 'MyArrayRef'
  22        => as 'ArrayRef'
  23        => where { defined $_->[0] }
  24        => message { ref $_ ? "ref: ". ref $_ : 'scalar' }  # stringy
  25     ;
  26
  27     subtype 'MyObjectType'
  28        => as 'Object'
  29        => where { $_->isa('MyObject') }
  30        => message {
  31           if ( $_->isa('SomeObject') ) {
  32             return 'More detailed error message';
  33           }
  34           elsif ( blessed $_ ) {
  35             return 'Well it is an object';
  36           }
  37           else {
  38             return 'Doh!';
  39           }
  40        }
  41     ;
  42
  43     type 'NewType'
  44        => where { $_->isa('MyObject') }
  45        => message { blessed $_ ? 'blessed' : 'scalar' }
  46     ;
  47
  48     has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
  49     has 'ar'  => ( is => 'rw', isa => 'MyArrayRef' );
  50     has 'nt'  => ( is => 'rw', isa => 'NewType' );
  51 }
  52
  53 my $foo = Foo->new;
  54 my $obj = MyObject->new;
  55
  56 throws_ok {
  57     $foo->ar( [] );
  58 }
  59 qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/,
  60     '... got the right error message';
  61
  62 throws_ok {
  63     $foo->obj($foo);    # Doh!
  64 }
  65 qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/,
  66     '... got the right error message';
  67
  68 throws_ok {
  69     $foo->nt($foo);     # scalar
  70 }
  71 qr/Attribute \(nt\) does not pass the type constraint because: blessed/,
  72     '... got the right error message';
  73