t/100_bugs/017_type_constraint_messages.t

   1 #!/usr/bin/perl
   2 # This is automatically generated by author/import-moose-test.pl.
   3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
   4 use t::lib::MooseCompat;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 use Test::Exception;
  11
  12
  13 # RT #37569
  14
  15 {
  16     package MyObject;
  17     use Mouse;
  18
  19     package Foo;
  20     use Mouse;
  21     use Mouse::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 }
  61 qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/,
  62     '... got the right error message';
  63
  64 throws_ok {
  65     $foo->obj($foo);    # Doh!
  66 }
  67 qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/,
  68     '... got the right error message';
  69
  70 throws_ok {
  71     $foo->nt($foo);     # scalar
  72 }
  73 qr/Attribute \(nt\) does not pass the type constraint because: blessed/,
  74     '... got the right error message';
  75
  76 done_testing;