t/001_mouse/802-coerce_multi_class.t

   1 use strict;
   2 use warnings;
   3 use Test::More tests => 13;
   4
   5 {
   6     package Response::Headers;
   7     use Mouse;
   8     has 'foo' => ( is => 'rw' );
   9 }
  10 {
  11     package Request::Headers;
  12     use Mouse;
  13     has 'foo' => ( is => 'rw' );
  14 }
  15
  16 {
  17     package Response;
  18     use Mouse;
  19     use Mouse::Util::TypeConstraints;
  20
  21     subtype 'Headers' => as 'Object', where { $_->isa('Response::Headers') };
  22     coerce 'Headers' =>
  23         from 'HashRef' => via {
  24             Response::Headers->new(%{ $_ });
  25         },
  26     ;
  27
  28     has headers => (
  29         is     => 'rw',
  30         isa    => 'Headers',
  31         coerce => 1,
  32     );
  33 }
  34
  35 eval {
  36     package Request;
  37     use Mouse::Util::TypeConstraints;
  38
  39     type 'Headers' => where { defined $_ && eval { $_->isa('Request::Headers') } };
  40 };
  41 like $@, qr/The type constraint 'Headers' has already been created in Response and cannot be created again in Request/;
  42
  43 eval {
  44     package Request;
  45     use Mouse::Util::TypeConstraints;
  46
  47     coerce 'TooBad' =>
  48         from 'HashRef' => via {
  49             Request::Headers->new(%{ $_ });
  50         },
  51     ;
  52 };
  53 like $@, qr/Cannot find type 'TooBad', perhaps you forgot to load it./;
  54
  55 eval {
  56     package Request;
  57     use Mouse::Util::TypeConstraints;
  58
  59     coerce 'Headers' =>
  60         from 'HashRef' => via {
  61             Request::Headers->new(%{ $_ });
  62         },
  63     ;
  64 };
  65 like $@, qr/A coercion action already exists for 'HashRef'/;
  66
  67 eval {
  68     package Request;
  69     use Mouse::Util::TypeConstraints;
  70
  71     coerce 'Int' =>
  72         from 'XXX' => via {
  73             1
  74         },
  75     ;
  76 };
  77 like $@, qr/Could not find the type constraint \(XXX\) to coerce from/;
  78
  79 eval {
  80     package Request;
  81     use Mouse::Util::TypeConstraints;
  82
  83     coerce 'Headers' =>
  84         from 'ArrayRef' => via {
  85             Request::Headers->new(%{ $_ });
  86         },
  87     ;
  88 };
  89 ok !$@;
  90
  91 {
  92     package Request;
  93     use Mouse;
  94
  95     has headers => (
  96         is     => 'rw',
  97         isa    => 'Headers',
  98         coerce => 1,
  99     );
 100 }
 101
 102 my $req = Request->new(headers => { foo => 'bar' });
 103 isa_ok($req->headers, 'Response::Headers');
 104 is($req->headers->foo, 'bar');
 105 $req->headers({foo => 'yay'});
 106 isa_ok($req->headers, 'Response::Headers');
 107 is($req->headers->foo, 'yay');
 108
 109 my $res = Response->new(headers => { foo => 'bar' });
 110 isa_ok($res->headers, 'Response::Headers');
 111 is($res->headers->foo, 'bar');
 112 $res->headers({foo => 'yay'});
 113 isa_ok($res->headers, 'Response::Headers');
 114 is($res->headers->foo, 'yay');
 115