t/type_constraints/union_types_and_coercions.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8
   9 use Test::Requires {
  10     'IO::String' => '0.01', # skip all if not installed
  11     'IO::File' => '0.01',
  12 };
  13
  14 {
  15     package Email::Moose;
  16     use Moose;
  17     use Moose::Util::TypeConstraints;
  18
  19     use IO::String;
  20
  21     our $VERSION = '0.01';
  22
  23     # create subtype for IO::String
  24
  25     subtype 'IO::String'
  26         => as 'Object'
  27         => where { $_->isa('IO::String') };
  28
  29     coerce 'IO::String'
  30         => from 'Str'
  31             => via { IO::String->new($_) },
  32         => from 'ScalarRef',
  33             => via { IO::String->new($_) };
  34
  35     # create subtype for IO::File
  36
  37     subtype 'IO::File'
  38         => as 'Object'
  39         => where { $_->isa('IO::File') };
  40
  41     coerce 'IO::File'
  42         => from 'FileHandle'
  43             => via { bless $_, 'IO::File' };
  44
  45     # create the alias
  46
  47     subtype 'IO::StringOrFile' => as 'IO::String | IO::File';
  48
  49     # attributes
  50
  51     has 'raw_body' => (
  52         is      => 'rw',
  53         isa     => 'IO::StringOrFile',
  54         coerce  => 1,
  55         default => sub { IO::String->new() },
  56     );
  57
  58     sub as_string {
  59         my ($self) = @_;
  60         my $fh = $self->raw_body();
  61         return do { local $/; <$fh> };
  62     }
  63 }
  64
  65 {
  66     my $email = Email::Moose->new;
  67     isa_ok($email, 'Email::Moose');
  68
  69     isa_ok($email->raw_body, 'IO::String');
  70
  71     is($email->as_string, undef, '... got correct empty string');
  72 }
  73
  74 {
  75     my $email = Email::Moose->new(raw_body => '... this is my body ...');
  76     isa_ok($email, 'Email::Moose');
  77
  78     isa_ok($email->raw_body, 'IO::String');
  79
  80     is($email->as_string, '... this is my body ...', '... got correct string');
  81
  82     is( exception {
  83         $email->raw_body('... this is the next body ...');
  84     }, undef, '... this will coerce correctly' );
  85
  86     isa_ok($email->raw_body, 'IO::String');
  87
  88     is($email->as_string, '... this is the next body ...', '... got correct string');
  89 }
  90
  91 {
  92     my $str = '... this is my body (ref) ...';
  93
  94     my $email = Email::Moose->new(raw_body => \$str);
  95     isa_ok($email, 'Email::Moose');
  96
  97     isa_ok($email->raw_body, 'IO::String');
  98
  99     is($email->as_string, $str, '... got correct string');
 100
 101     my $str2 = '... this is the next body (ref) ...';
 102
 103     is( exception {
 104         $email->raw_body(\$str2);
 105     }, undef, '... this will coerce correctly' );
 106
 107     isa_ok($email->raw_body, 'IO::String');
 108
 109     is($email->as_string, $str2, '... got correct string');
 110 }
 111
 112 {
 113     my $io_str = IO::String->new('... this is my body (IO::String) ...');
 114
 115     my $email = Email::Moose->new(raw_body => $io_str);
 116     isa_ok($email, 'Email::Moose');
 117
 118     isa_ok($email->raw_body, 'IO::String');
 119     is($email->raw_body, $io_str, '... and it is the one we expected');
 120
 121     is($email->as_string, '... this is my body (IO::String) ...', '... got correct string');
 122
 123     my $io_str2 = IO::String->new('... this is the next body (IO::String) ...');
 124
 125     is( exception {
 126         $email->raw_body($io_str2);
 127     }, undef, '... this will coerce correctly' );
 128
 129     isa_ok($email->raw_body, 'IO::String');
 130     is($email->raw_body, $io_str2, '... and it is the one we expected');
 131
 132     is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string');
 133 }
 134
 135 {
 136     my $fh;
 137
 138     open($fh, '<', $0) || die "Could not open $0";
 139
 140     my $email = Email::Moose->new(raw_body => $fh);
 141     isa_ok($email, 'Email::Moose');
 142
 143     isa_ok($email->raw_body, 'IO::File');
 144
 145     close($fh);
 146 }
 147
 148 {
 149     my $fh = IO::File->new($0);
 150
 151     my $email = Email::Moose->new(raw_body => $fh);
 152     isa_ok($email, 'Email::Moose');
 153
 154     isa_ok($email->raw_body, 'IO::File');
 155     is($email->raw_body, $fh, '... and it is the one we expected');
 156 }
 157
 158 {
 159     package Foo;
 160
 161     use Moose;
 162     use Moose::Util::TypeConstraints;
 163
 164     subtype 'Coerced' => as 'ArrayRef';
 165     coerce 'Coerced'
 166         => from 'Value'
 167         => via { [ $_ ] };
 168
 169     has carray => (
 170         is     => 'ro',
 171         isa    => 'Coerced | Coerced',
 172         coerce => 1,
 173     );
 174 }
 175
 176 {
 177     my $foo;
 178     is( exception { $foo = Foo->new( carray => 1 ) }, undef, 'Can pass non-ref value for carray' );
 179     is_deeply(
 180         $foo->carray, [1],
 181         'carray was coerced to an array ref'
 182     );
 183
 184     like( exception { Foo->new( carray => {} ) }, qr/\QValidation failed for 'Coerced|Coerced' with value \E(?!undef)/, 'Cannot pass a hash ref for carray attribute, and hash ref is not coerced to an undef' );
 185 }
 186
 187 done_testing;