t/800_shikabased/010-isa-or.t

   1 use strict;
   2 use warnings;
   3 use Test::More tests => 18;
   4
   5 {
   6     package Foo;
   7     use Mouse;
   8     use Mouse::Util::TypeConstraints;
   9     subtype Baz => where { defined($_) && $_ eq 'Baz' };
  10     coerce Baz => from 'ArrayRef', via { 'Baz' };
  11     has 'bar' => ( is => 'rw', isa => 'Str | Baz | Undef', coerce => 1 );
  12 }
  13
  14 eval {
  15     Foo->new( bar => +{} );
  16 };
  17 ok $@, 'not got an object';
  18
  19 eval {
  20     isa_ok(Foo->new( bar => undef ), 'Foo');
  21 };
  22 ok !$@, 'got an object 1';
  23
  24 eval {
  25     isa_ok(Foo->new( bar => 'foo' ), 'Foo');
  26
  27 };
  28 ok !$@, 'got an object 2';
  29
  30
  31 my $f = Foo->new;
  32 eval {
  33     $f->bar([]);
  34 };
  35 ok !$@;
  36 is $f->bar, 'Baz', 'bar is baz (coerce from ArrayRef)';
  37
  38 eval {
  39     $f->bar('hoge');
  40 };
  41 ok !$@;
  42 is $f->bar, 'hoge', 'bar is hoge';
  43
  44 eval {
  45     $f->bar(undef);
  46 };
  47 ok !$@;
  48 is $f->bar, undef, 'bar is undef';
  49
  50
  51 {
  52     package Bar;
  53     use Mouse;
  54     use Mouse::Util::TypeConstraints;
  55
  56     subtype 'Type1' => where { defined($_) && $_ eq 'Name' };
  57     coerce 'Type1', from 'Str', via { 'Names' };
  58
  59     subtype 'Type2' => where { defined($_) && $_ eq 'Group' };
  60     coerce 'Type2', from 'Str', via { 'Name' };
  61
  62     has 'foo' => ( is => 'rw', isa => 'Type1|Type2', coerce => 1 );
  63 }
  64
  65 my $foo = Bar->new( foo => 'aaa' );
  66 ok $foo, 'got an object 3';
  67 is $foo->foo, 'Name', 'foo is Name';
  68
  69
  70 {
  71     package KLASS;
  72     sub new { bless {}, shift };
  73 }
  74 {
  75     package Baz;
  76     use Mouse;
  77     use Mouse::Util::TypeConstraints;
  78
  79     subtype 'Type3' => where { defined($_) && $_ eq 'Name' };
  80     coerce 'Type3', from 'CodeRef', via { 'Name' };
  81
  82     has 'foo' => ( is => 'rw', isa => 'Type3|KLASS|Undef', coerce => 1 );
  83 }
  84
  85 eval { Baz->new( foo => 'aaa' ) };
  86 like $@, qr/Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Type3\|KLASS\|Undef' failed with value aaa/;
  87
  88 my $k = Baz->new;
  89 ok $k, 'got an object 4';
  90 $k->foo(sub {});
  91 is $k->foo, 'Name', 'foo is Name';
  92 $k->foo(KLASS->new);
  93 isa_ok $k->foo, 'KLASS';
  94 $k->foo(undef);
  95 is $k->foo, undef, 'foo is undef';
  96