From: Stevan Little Date: Sun, 24 Sep 2006 02:16:09 +0000 (+0000) Subject: foo X-Git-Tag: 0_14~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a5bd159bfe05bc23ca4ce974e83dbaf85a6be71;p=gitmo%2FMoose.git foo --- diff --git a/Changes b/Changes index 916bc50..f90c44f 100644 --- a/Changes +++ b/Changes @@ -10,16 +10,13 @@ Revision history for Perl extension Moose - Removed the use of UNIVERSAL::require to be a better symbol table citizen and remove a dependency (thanks Adam Kennedy) - - unimport now returns a true value, this should allow - 'no Moose' to be used instead of 1; at the end of a - module. * Moose::Cookbook - added a FAQ and WTF files to document frequently asked questions and common problems * Moose::Util::TypeConstraints - - added GlobRef type constraint + - added GlobRef and FileHandle type constraint - added tests for this * Moose::Meta::Attribute @@ -32,9 +29,20 @@ Revision history for Perl extension Moose * Moose::Meta::Role - added basic support for runtime role composition - but this is still highly experimental + but this is still *highly experimental*, so feedback + is much appreciated :) - added tests for this + * Moose::Meta::TypeConstraint + - the type constraint now handles the coercion process + through delegation, this is to support the coercion + of unions + + * Moose::Meta::TypeConstraint::Union + - it is now possible for coercions to be performed + on a type union + - added tests for this (thanks to konobi) + * Moose::Meta::TypeCoercion - properly capturing error when type constraint is not found diff --git a/lib/Moose.pm b/lib/Moose.pm index 89b9e61..5005341 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -1,4 +1,6 @@ +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/trunk/lib'; + package Moose; use strict; @@ -207,11 +209,6 @@ use Moose::Util::TypeConstraints; delete ${$class . '::'}{$name}; } } - - # return a true value - # so that it can be used - # as a module end - 1; } } diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 8b49cd5..2bbc6ad 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util 'blessed', 'weaken', 'reftype'; use Carp 'confess'; -our $VERSION = '0.06'; +our $VERSION = '0.07'; use Moose::Util::TypeConstraints (); @@ -161,8 +161,8 @@ sub _process_options { if (exists $options->{coerce} && $options->{coerce}) { (exists $options->{type_constraint}) || confess "You cannot have coercion without specifying a type constraint"; - (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union')) - || confess "You cannot have coercion with a type constraint union"; + #(!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union')) + # || confess "You cannot have coercion with a type constraint union"; confess "You cannot have a weak reference to a coerced value" if $options->{weak_ref}; } @@ -216,7 +216,7 @@ sub initialize_instance_slot { if ($self->has_type_constraint) { my $type_constraint = $self->type_constraint; if ($self->should_coerce && $type_constraint->has_coercion) { - $val = $type_constraint->coercion->coerce($val); + $val = $type_constraint->coerce($val); } (defined($type_constraint->check($val))) || confess "Attribute (" . @@ -250,7 +250,7 @@ EOF sub _inline_check_coercion { my $self = shift; return '' unless $self->should_coerce; - return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);' + return 'my $val = $attr->type_constraint->coerce($_[1]);' } sub _inline_check_required { diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index e4dc9bb..7f03b58 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -9,7 +9,7 @@ use Sub::Name 'subname'; use Carp 'confess'; use Scalar::Util 'blessed'; -our $VERSION = '0.04'; +our $VERSION = '0.05'; __PACKAGE__->meta->add_attribute('name' => (reader => 'name' )); __PACKAGE__->meta->add_attribute('parent' => (reader => 'parent' )); @@ -35,6 +35,10 @@ sub new { return $self; } +sub coerce { + ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) +} + sub compile_type_constraint { my $self = shift; my $check = $self->constraint; @@ -101,7 +105,7 @@ sub union { || confess "You must pass in only Moose::Meta::TypeConstraint instances to make unions" foreach @type_constraints; return Moose::Meta::TypeConstraint::Union->new( - type_constraints => \@type_constraints + type_constraints => \@type_constraints, ); } @@ -111,7 +115,7 @@ use strict; use warnings; use metaclass; -our $VERSION = '0.01'; +our $VERSION = '0.02'; __PACKAGE__->meta->add_attribute('type_constraints' => ( accessor => 'type_constraints', @@ -136,11 +140,39 @@ sub constraint { # conform to the TypeConstraint API sub parent { undef } -sub coercion { undef } -sub has_coercion { 0 } sub message { undef } sub has_message { 0 } +# FIXME: +# not sure what this should actually do here +sub coercion { undef } + +# this should probably be memoized +sub has_coercion { + my $self = shift; + foreach my $type (@{$self->type_constraints}) { + return 1 if $type->has_coercion + } + return 0; +} + +# NOTE: +# this feels too simple, and may not always DWIM +# correctly, especially in the presence of +# close subtype relationships, however it should +# work for a fair percentage of the use cases +sub coerce { + my $self = shift; + my $value = shift; + foreach my $type (@{$self->type_constraints}) { + if ($type->has_coercion) { + my $temp = $type->coerce($value); + return $temp if $self->check($temp); + } + } + return undef; +} + sub check { my $self = shift; my $value = shift; @@ -217,6 +249,10 @@ checks if it is a subtype of it. =item B +=item B + +This will apply the type-coercion if applicable. + =item B This method will return a true (C<1>) if the C<$value> passes the diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index dbd4844..056d052 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -144,6 +144,11 @@ subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' }; subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' }; +# NOTE: +# scalar filehandles are GLOB refs, +# but a GLOB ref is not always a filehandle +subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) }; + # NOTE: # blessed(qr/.../) returns true,.. how odd subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; @@ -241,6 +246,7 @@ could probably use some work, but it works for me at the moment. CodeRef RegexpRef GlobRef + FileHandle Object Role diff --git a/t/052_util_std_type_constraints.t b/t/052_util_std_type_constraints.t index 19e7da9..b126cbf 100644 --- a/t/052_util_std_type_constraints.t +++ b/t/052_util_std_type_constraints.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 223; +use Test::More tests => 254; use Test::Exception; use Scalar::Util (); @@ -17,6 +17,9 @@ my $SCALAR_REF = \(my $var); no warnings 'once'; # << I *hates* that warning ... my $GLOB_REF = \*GLOB_REF; +my $fh; +open($fh, '<', $0) || die "Could not open $0 for the test"; + Moose::Util::TypeConstraints->export_type_contstraints_as_functions(); ok(defined Any(0), '... Any accepts anything'); @@ -28,6 +31,7 @@ ok(defined Any({}), '... Any accepts anything'); ok(defined Any(sub {}), '... Any accepts anything'); ok(defined Any($SCALAR_REF), '... Any accepts anything'); ok(defined Any($GLOB_REF), '... Any accepts anything'); +ok(defined Any($fh), '... Any accepts anything'); ok(defined Any(qr/../), '... Any accepts anything'); ok(defined Any(bless {}, 'Foo'), '... Any accepts anything'); ok(defined Any(undef), '... Any accepts anything'); @@ -41,6 +45,7 @@ ok(defined Item({}), '... Item is the base type, so accepts anythin ok(defined Item(sub {}), '... Item is the base type, so accepts anything'); ok(defined Item($SCALAR_REF), '... Item is the base type, so accepts anything'); ok(defined Item($GLOB_REF), '... Item is the base type, so accepts anything'); +ok(defined Item($fh), '... Item is the base type, so accepts anything'); ok(defined Item(qr/../), '... Item is the base type, so accepts anything'); ok(defined Item(bless {}, 'Foo'), '... Item is the base type, so accepts anything'); ok(defined Item(undef), '... Item is the base type, so accepts anything'); @@ -54,6 +59,7 @@ ok(defined Defined({}), '... Defined accepts anything which is defi ok(defined Defined(sub {}), '... Defined accepts anything which is defined'); ok(defined Defined($SCALAR_REF), '... Defined accepts anything which is defined'); ok(defined Defined($GLOB_REF), '... Defined accepts anything which is defined'); +ok(defined Defined($fh), '... Defined accepts anything which is defined'); ok(defined Defined(qr/../), '... Defined accepts anything which is defined'); ok(defined Defined(bless {}, 'Foo'), '... Defined accepts anything which is defined'); ok(!defined Defined(undef), '... Defined accepts anything which is defined'); @@ -67,6 +73,7 @@ ok(!defined Undef({}), '... Undef accepts anything which is not def ok(!defined Undef(sub {}), '... Undef accepts anything which is not defined'); ok(!defined Undef($SCALAR_REF), '... Undef accepts anything which is not defined'); ok(!defined Undef($GLOB_REF), '... Undef accepts anything which is not defined'); +ok(!defined Undef($fh), '... Undef accepts anything which is not defined'); ok(!defined Undef(qr/../), '... Undef accepts anything which is not defined'); ok(!defined Undef(bless {}, 'Foo'), '... Undef accepts anything which is not defined'); ok(defined Undef(undef), '... Undef accepts anything which is not defined'); @@ -81,6 +88,7 @@ ok(!defined Bool({}), '... Bool rejects anything which is not a 1 ok(!defined Bool(sub {}), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); ok(!defined Bool($SCALAR_REF), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); ok(!defined Bool($GLOB_REF), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(!defined Bool($fh), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); ok(!defined Bool(qr/../), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); ok(!defined Bool(bless {}, 'Foo'), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); ok(defined Bool(undef), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); @@ -94,6 +102,7 @@ ok(!defined Value({}), '... Value rejects anything which is not a ok(!defined Value(sub {}), '... Value rejects anything which is not a Value'); ok(!defined Value($SCALAR_REF), '... Value rejects anything which is not a Value'); ok(!defined Value($GLOB_REF), '... Value rejects anything which is not a Value'); +ok(!defined Value($fh), '... Value rejects anything which is not a Value'); ok(!defined Value(qr/../), '... Value rejects anything which is not a Value'); ok(!defined Value(bless {}, 'Foo'), '... Value rejects anything which is not a Value'); ok(!defined Value(undef), '... Value rejects anything which is not a Value'); @@ -107,6 +116,7 @@ ok(defined Ref({}), '... Ref rejects anything which is not a Ref') ok(defined Ref(sub {}), '... Ref rejects anything which is not a Ref'); ok(defined Ref($SCALAR_REF), '... Ref rejects anything which is not a Ref'); ok(defined Ref($GLOB_REF), '... Ref rejects anything which is not a Ref'); +ok(defined Ref($fh), '... Ref rejects anything which is not a Ref'); ok(defined Ref(qr/../), '... Ref rejects anything which is not a Ref'); ok(defined Ref(bless {}, 'Foo'), '... Ref rejects anything which is not a Ref'); ok(!defined Ref(undef), '... Ref rejects anything which is not a Ref'); @@ -122,6 +132,7 @@ ok(!defined Int({}), '... Int rejects anything which is not a Int' ok(!defined Int(sub {}), '... Int rejects anything which is not a Int'); ok(!defined Int($SCALAR_REF), '... Int rejects anything which is not a Int'); ok(!defined Int($GLOB_REF), '... Int rejects anything which is not a Int'); +ok(!defined Int($fh), '... Int rejects anything which is not a Int'); ok(!defined Int(qr/../), '... Int rejects anything which is not a Int'); ok(!defined Int(bless {}, 'Foo'), '... Int rejects anything which is not a Int'); ok(!defined Int(undef), '... Int rejects anything which is not a Int'); @@ -137,6 +148,7 @@ ok(!defined Num({}), '... Num rejects anything which is not a Num' ok(!defined Num(sub {}), '... Num rejects anything which is not a Num'); ok(!defined Num($SCALAR_REF), '... Num rejects anything which is not a Num'); ok(!defined Num($GLOB_REF), '... Num rejects anything which is not a Num'); +ok(!defined Num($fh), '... Num rejects anything which is not a Num'); ok(!defined Num(qr/../), '... Num rejects anything which is not a Num'); ok(!defined Num(bless {}, 'Foo'), '... Num rejects anything which is not a Num'); ok(!defined Num(undef), '... Num rejects anything which is not a Num'); @@ -149,6 +161,7 @@ ok(!defined Str([]), '... Str rejects anything which is not a Str' ok(!defined Str({}), '... Str rejects anything which is not a Str'); ok(!defined Str(sub {}), '... Str rejects anything which is not a Str'); ok(!defined Str($SCALAR_REF), '... Str rejects anything which is not a Str'); +ok(!defined Str($fh), '... Str rejects anything which is not a Str'); ok(!defined Str($GLOB_REF), '... Str rejects anything which is not a Str'); ok(!defined Str(qr/../), '... Str rejects anything which is not a Str'); ok(!defined Str(bless {}, 'Foo'), '... Str rejects anything which is not a Str'); @@ -163,6 +176,7 @@ ok(!defined ScalarRef({}), '... ScalarRef rejects anything which i ok(!defined ScalarRef(sub {}), '... ScalarRef rejects anything which is not a ScalarRef'); ok(defined ScalarRef($SCALAR_REF), '... ScalarRef accepts anything which is a ScalarRef'); ok(!defined ScalarRef($GLOB_REF), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef($fh), '... ScalarRef rejects anything which is not a ScalarRef'); ok(!defined ScalarRef(qr/../), '... ScalarRef rejects anything which is not a ScalarRef'); ok(!defined ScalarRef(bless {}, 'Foo'), '... ScalarRef rejects anything which is not a ScalarRef'); ok(!defined ScalarRef(undef), '... ScalarRef rejects anything which is not a ScalarRef'); @@ -176,6 +190,7 @@ ok(!defined ArrayRef({}), '... ArrayRef rejects anything which is ok(!defined ArrayRef(sub {}), '... ArrayRef rejects anything which is not a ArrayRef'); ok(!defined ArrayRef($SCALAR_REF), '... ArrayRef rejects anything which is not a ArrayRef'); ok(!defined ArrayRef($GLOB_REF), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef($fh), '... ArrayRef rejects anything which is not a ArrayRef'); ok(!defined ArrayRef(qr/../), '... ArrayRef rejects anything which is not a ArrayRef'); ok(!defined ArrayRef(bless {}, 'Foo'), '... ArrayRef rejects anything which is not a ArrayRef'); ok(!defined ArrayRef(undef), '... ArrayRef rejects anything which is not a ArrayRef'); @@ -189,6 +204,7 @@ ok(defined HashRef({}), '... HashRef accepts anything which is a ok(!defined HashRef(sub {}), '... HashRef rejects anything which is not a HashRef'); ok(!defined HashRef($SCALAR_REF), '... HashRef rejects anything which is not a HashRef'); ok(!defined HashRef($GLOB_REF), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef($fh), '... HashRef rejects anything which is not a HashRef'); ok(!defined HashRef(qr/../), '... HashRef rejects anything which is not a HashRef'); ok(!defined HashRef(bless {}, 'Foo'), '... HashRef rejects anything which is not a HashRef'); ok(!defined HashRef(undef), '... HashRef rejects anything which is not a HashRef'); @@ -202,6 +218,7 @@ ok(!defined CodeRef({}), '... CodeRef rejects anything which is no ok(defined CodeRef(sub {}), '... CodeRef accepts anything which is a CodeRef'); ok(!defined CodeRef($SCALAR_REF), '... CodeRef rejects anything which is not a CodeRef'); ok(!defined CodeRef($GLOB_REF), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef($fh), '... CodeRef rejects anything which is not a CodeRef'); ok(!defined CodeRef(qr/../), '... CodeRef rejects anything which is not a CodeRef'); ok(!defined CodeRef(bless {}, 'Foo'), '... CodeRef rejects anything which is not a CodeRef'); ok(!defined CodeRef(undef), '... CodeRef rejects anything which is not a CodeRef'); @@ -215,6 +232,7 @@ ok(!defined RegexpRef({}), '... RegexpRef rejects anything which i ok(!defined RegexpRef(sub {}), '... RegexpRef rejects anything which is not a RegexpRef'); ok(!defined RegexpRef($SCALAR_REF), '... RegexpRef rejects anything which is not a RegexpRef'); ok(!defined RegexpRef($GLOB_REF), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef($fh), '... RegexpRef rejects anything which is not a RegexpRef'); ok(defined RegexpRef(qr/../), '... RegexpRef accepts anything which is a RegexpRef'); ok(!defined RegexpRef(bless {}, 'Foo'), '... RegexpRef rejects anything which is not a RegexpRef'); ok(!defined RegexpRef(undef), '... RegexpRef rejects anything which is not a RegexpRef'); @@ -227,11 +245,26 @@ ok(!defined GlobRef([]), '... GlobRef rejects anything which is no ok(!defined GlobRef({}), '... GlobRef rejects anything which is not a GlobRef'); ok(!defined GlobRef(sub {}), '... GlobRef rejects anything which is not a GlobRef'); ok(!defined GlobRef($SCALAR_REF), '... GlobRef rejects anything which is not a GlobRef'); -ok(defined GlobRef($GLOB_REF), '... GlobRef rejects anything which is a GlobRef'); -ok(!defined GlobRef(qr/../), '... GlobRef accepts anything which is not a GlobRef'); +ok(defined GlobRef($GLOB_REF), '... GlobRef accepts anything which is a GlobRef'); +ok(defined GlobRef($fh), '... GlobRef accepts anything which is a GlobRef'); +ok(!defined GlobRef(qr/../), '... GlobRef rejects anything which is not a GlobRef'); ok(!defined GlobRef(bless {}, 'Foo'), '... GlobRef rejects anything which is not a GlobRef'); ok(!defined GlobRef(undef), '... GlobRef rejects anything which is not a GlobRef'); +ok(!defined FileHandle(0), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle(100), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle(''), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle('Foo'), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle([]), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle({}), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle(sub {}), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle($SCALAR_REF), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle($GLOB_REF), '... FileHandle rejects anything which is not a FileHandle'); +ok(defined FileHandle($fh), '... FileHandle accepts anything which is a FileHandle'); +ok(!defined FileHandle(qr/../), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle(bless {}, 'Foo'), '... FileHandle rejects anything which is not a FileHandle'); +ok(!defined FileHandle(undef), '... FileHandle rejects anything which is not a FileHandle'); + ok(!defined Object(0), '... Object rejects anything which is not blessed'); ok(!defined Object(100), '... Object rejects anything which is not blessed'); ok(!defined Object(''), '... Object rejects anything which is not blessed'); @@ -241,6 +274,7 @@ ok(!defined Object({}), '... Object rejects anything which is not ok(!defined Object(sub {}), '... Object rejects anything which is not blessed'); ok(!defined Object($SCALAR_REF), '... Object rejects anything which is not blessed'); ok(!defined Object($GLOB_REF), '... Object rejects anything which is not blessed'); +ok(!defined Object($fh), '... Object rejects anything which is not blessed'); ok(!defined Object(qr/../), '... Object rejects anything which is not blessed'); ok(defined Object(bless {}, 'Foo'), '... Object accepts anything which is blessed'); ok(!defined Object(undef), '... Object accepts anything which is blessed'); @@ -259,9 +293,10 @@ ok(!defined Role({}), '... Role rejects anything which is not ok(!defined Role(sub {}), '... Role rejects anything which is not a Role'); ok(!defined Role($SCALAR_REF), '... Role rejects anything which is not a Role'); ok(!defined Role($GLOB_REF), '... Role rejects anything which is not a Role'); +ok(!defined Role($fh), '... Role rejects anything which is not a Role'); ok(!defined Role(qr/../), '... Role rejects anything which is not a Role'); ok(!defined Role(bless {}, 'Foo'), '... Role accepts anything which is not a Role'); ok(defined Role(bless {}, 'My::Role'), '... Role accepts anything which is not a Role'); ok(!defined Role(undef), '... Role accepts anything which is not a Role'); - +close($fh) || die "Could not close the filehandle $0 for test"; diff --git a/t/058_union_types_and_coercions.t b/t/058_union_types_and_coercions.t index 2707454..c9a42b8 100644 --- a/t/058_union_types_and_coercions.t +++ b/t/058_union_types_and_coercions.t @@ -3,88 +3,158 @@ use strict; use warnings; -use Test::More tests => 1; +use Test::More; use Test::Exception; BEGIN { - use_ok('Moose'); + eval "use IO::String; use IO::File;"; + plan skip_all => "IO::String and IO::File are required for this test" if $@; + plan tests => 29; } -__END__ - -package Email::Moose; - -use warnings; -use strict; - -use Moose; -use Moose::Util::TypeConstraints; - -use IO::String; +BEGIN { + use_ok('Moose'); +} -=head1 NAME +{ + package Email::Moose; + use Moose; + use Moose::Util::TypeConstraints; -Email::Moose - Email::Simple on Moose steroids + use IO::String; -=head1 VERSION + our $VERSION = '0.01'; -Version 0.01 + # create subtype for IO::String -=cut + subtype 'IO::String' + => as 'Object' + => where { $_->isa('IO::String') }; -our $VERSION = '0.01'; + coerce 'IO::String' + => from 'Str' + => via { IO::String->new($_) }, + => from 'ScalarRef', + => via { IO::String->new($_) }; -=head1 SYNOPSIS + # create subtype for IO::File -=head1 METHODS + subtype 'IO::File' + => as 'Object' + => where { $_->isa('IO::File') }; -=head2 raw_body + coerce 'IO::File' + => from 'FileHandle' + => via { bless $_, 'IO::File' }; + + # attributes + + has 'raw_body' => ( + is => 'rw', + isa => 'IO::String | IO::File', + coerce => 1, + default => sub { IO::String->new() }, + ); + + sub as_string { + my ($self) = @_; + my $fh = $self->raw_body(); + return do { local $/; <$fh> }; + } +} -=cut +{ + my $email = Email::Moose->new; + isa_ok($email, 'Email::Moose'); -subtype q{IO::String} - => as q{Object} - => where { $_->isa(q{IO::String}) }; + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, undef, '... got correct empty string'); +} -coerce q{IO::String} - => from q{Str} - => via { IO::String->new($_) }, - => from q{ScalarRef}, - => via { IO::String->new($_) }; +{ + my $email = Email::Moose->new(raw_body => '... this is my body ...'); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is my body ...', '... got correct string'); + + lives_ok { + $email->raw_body('... this is the next body ...'); + } '... this will coerce correctly'; + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, '... this is the next body ...', '... got correct string'); +} -type q{FileHandle} - => where { Scalar::Util::openhandle($_) }; - -subtype q{IO::File} - => as q{Object} - => where { $_->isa(q{IO::File}) }; +{ + my $str = '... this is my body (ref) ...'; + + my $email = Email::Moose->new(raw_body => \$str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str, '... got correct string'); + + my $str2 = '... this is the next body (ref) ...'; + + lives_ok { + $email->raw_body(\$str2); + } '... this will coerce correctly'; + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, $str2, '... got correct string'); +} -coerce q{IO::File} - => from q{FileHandle} - => via { bless $_, q{IO::File} }; +{ + my $io_str = IO::String->new('... this is my body (IO::String) ...'); + + my $email = Email::Moose->new(raw_body => $io_str); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str, '... and it is the one we expected'); + + is($email->as_string, '... this is my body (IO::String) ...', '... got correct string'); + + my $io_str2 = IO::String->new('... this is the next body (IO::String) ...'); + + lives_ok { + $email->raw_body($io_str2); + } '... this will coerce correctly'; + + isa_ok($email->raw_body, 'IO::String'); + is($email->raw_body, $io_str2, '... and it is the one we expected'); + + is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string'); +} -subtype q{IO::Socket} - => as q{Object} - => where { $_->isa(q{IO::Socket}) }; +{ + my $fh; + + open($fh, '<', $0) || die "Could not open $0"; + + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + + close($fh); +} -coerce q{IO::Socket} - => from q{CodeRef} # no test sample yet - => via { IO::Socket->new($_) }; -=cut +{ + my $fh = IO::File->new($0); -has q{raw_body} => ( - is => q{rw}, - isa => q{IO::String | IO::File | IO::Socket}, - coerce => 1, - default => sub { IO::String->new() }, -); + my $email = Email::Moose->new(raw_body => $fh); + isa_ok($email, 'Email::Moose'); + + isa_ok($email->raw_body, 'IO::File'); + is($email->raw_body, $fh, '... and it is the one we expected'); +} -=head2 as_string -=cut -sub as_string { - my ($self) = @_; - my $fh = $self->raw_body(); - return do { local $/; <$fh> }; -} \ No newline at end of file