t/040_type_constraints/009_union_types_and_coercions.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     eval "use IO::String; use IO::File;";
  11     plan skip_all => "IO::String and IO::File are required for this test" if $@;
  12     plan tests => 28;
  13 }
  14
  15
  16
  17 {
  18     package Email::Mouse;
  19     use Mouse;
  20     use Mouse::Util::TypeConstraints;
  21
  22     use IO::String;
  23
  24     our $VERSION = '0.01';
  25
  26     # create subtype for IO::String
  27
  28     subtype 'IO::String'
  29         => as 'Object'
  30         => where { $_->isa('IO::String') };
  31
  32     coerce 'IO::String'
  33         => from 'Str'
  34             => via { IO::String->new($_) },
  35         => from 'ScalarRef',
  36             => via { IO::String->new($_) };
  37
  38     # create subtype for IO::File
  39
  40     subtype 'IO::File'
  41         => as 'Object'
  42         => where { $_->isa('IO::File') };
  43
  44     coerce 'IO::File'
  45         => from 'FileHandle'
  46             => via { bless $_, 'IO::File' };
  47
  48     # create the alias
  49
  50     my $st = subtype 'IO::StringOrFile' => as 'IO::String | IO::File';
  51     #::diag $st->dump;
  52
  53     # attributes
  54
  55     has 'raw_body' => (
  56         is      => 'rw',
  57         isa     => 'IO::StringOrFile',
  58         coerce  => 1,
  59         default => sub { IO::String->new() },
  60     );
  61
  62     sub as_string {
  63         my ($self) = @_;
  64         my $fh = $self->raw_body();
  65
  66         return do { local $/; <$fh> };
  67     }
  68 }
  69
  70 {
  71     my $email = Email::Mouse->new;
  72     isa_ok($email, 'Email::Mouse');
  73
  74     isa_ok($email->raw_body, 'IO::String');
  75
  76     is($email->as_string, undef, '... got correct empty string');
  77 }
  78
  79 {
  80     my $email = Email::Mouse->new(raw_body => '... this is my body ...');
  81     isa_ok($email, 'Email::Mouse');
  82
  83     isa_ok($email->raw_body, 'IO::String');
  84
  85     is($email->as_string, '... this is my body ...', '... got correct string');
  86
  87     lives_ok {
  88         $email->raw_body('... this is the next body ...');
  89     } '... this will coerce correctly';
  90
  91     isa_ok($email->raw_body, 'IO::String');
  92
  93     is($email->as_string, '... this is the next body ...', '... got correct string');
  94 }
  95
  96 {
  97     my $str = '... this is my body (ref) ...';
  98
  99     my $email = Email::Mouse->new(raw_body => \$str);
 100     isa_ok($email, 'Email::Mouse');
 101
 102     isa_ok($email->raw_body, 'IO::String');
 103
 104     is($email->as_string, $str, '... got correct string');
 105
 106     my $str2 = '... this is the next body (ref) ...';
 107
 108     lives_ok {
 109         $email->raw_body(\$str2);
 110     } '... this will coerce correctly';
 111
 112     isa_ok($email->raw_body, 'IO::String');
 113
 114     is($email->as_string, $str2, '... got correct string');
 115 }
 116
 117 {
 118     my $io_str = IO::String->new('... this is my body (IO::String) ...');
 119
 120     my $email = Email::Mouse->new(raw_body => $io_str);
 121     isa_ok($email, 'Email::Mouse');
 122
 123     isa_ok($email->raw_body, 'IO::String');
 124     is($email->raw_body, $io_str, '... and it is the one we expected');
 125
 126     is($email->as_string, '... this is my body (IO::String) ...', '... got correct string');
 127
 128     my $io_str2 = IO::String->new('... this is the next body (IO::String) ...');
 129
 130     lives_ok {
 131         $email->raw_body($io_str2);
 132     } '... this will coerce correctly';
 133
 134     isa_ok($email->raw_body, 'IO::String');
 135     is($email->raw_body, $io_str2, '... and it is the one we expected');
 136
 137     is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string');
 138 }
 139
 140 {
 141     my $fh;
 142
 143     open($fh, '<', $0) || die "Could not open $0";
 144
 145     my $email = Email::Mouse->new(raw_body => $fh);
 146     isa_ok($email, 'Email::Mouse');
 147
 148     isa_ok($email->raw_body, 'IO::File');
 149
 150     close($fh);
 151 }
 152
 153 {
 154     my $fh = IO::File->new($0);
 155
 156     my $email = Email::Mouse->new(raw_body => $fh);
 157     isa_ok($email, 'Email::Mouse');
 158
 159     isa_ok($email->raw_body, 'IO::File');
 160     is($email->raw_body, $fh, '... and it is the one we expected');
 161 }
 162
 163
 164