t/100_bugs/017_type_constraint_messages.t

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