t/bugs/type_constraint_messages.t

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