From: gfx Date: Mon, 19 Oct 2009 08:39:08 +0000 (+0900) Subject: Import tc tests X-Git-Tag: 0.40~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b2b106d765ef1bcbb5ea3b215668baea1a9504b6;hp=61fcd0dad2a4b4bc1f616b95b9c162597098503a;p=gitmo%2FMouse.git Import tc tests --- diff --git a/t/040_type_constraints/failing/001_util_type_constraints.t b/t/040_type_constraints/failing/001_util_type_constraints.t new file mode 100644 index 0000000..a928ff5 --- /dev/null +++ b/t/040_type_constraints/failing/001_util_type_constraints.t @@ -0,0 +1,229 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 85; +use Test::Exception; + +use Scalar::Util (); + +use lib 't/lib'; +use Test::Mouse; +use Mouse::Util::TypeConstraints; + + +type Number => where { Scalar::Util::looks_like_number($_) }; +type String + => where { !ref($_) && !Number($_) } + => message { "This is not a string ($_)" }; + +subtype Natural + => as Number + => where { $_ > 0 }; + +subtype NaturalLessThanTen + => as Natural + => where { $_ < 10 } + => message { "The number '$_' is not less than 10" }; + +Mouse::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Number(5), '... this is a Num'); +ok(!defined(Number('Foo')), '... this is not a Num'); +{ + my $number_tc = Mouse::Util::TypeConstraints::find_type_constraint('Number'); + is("$number_tc", 'Number', '... type constraint stringifies to name'); +} + +ok(String('Foo'), '... this is a Str'); +ok(!defined(String(5)), '... this is not a Str'); + +ok(Natural(5), '... this is a Natural'); +is(Natural(-5), undef, '... this is not a Natural'); +is(Natural('Foo'), undef, '... this is not a Natural'); + +ok(NaturalLessThanTen(5), '... this is a NaturalLessThanTen'); +is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen'); +is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); + +# anon sub-typing + +my $negative = subtype Number => where { $_ < 0 }; +ok(defined $negative, '... got a value back from negative'); +isa_ok($negative, 'Mouse::Meta::TypeConstraint'); + +ok($negative->check(-5), '... this is a negative number'); +ok(!defined($negative->check(5)), '... this is not a negative number'); +is($negative->check('Foo'), undef, '... this is not a negative number'); + +ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number'); +ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String'); + +my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"}; + +ok(defined $negative2, '... got a value back from negative'); +isa_ok($negative2, 'Mouse::Meta::TypeConstraint'); + +ok($negative2->check(-5), '... this is a negative number'); +ok(!defined($negative2->check(5)), '... this is not a negative number'); +is($negative2->check('Foo'), undef, '... this is not a negative number'); + +ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number'); +ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String'); + +ok($negative2->has_message, '... it has a message'); +is($negative2->validate(2), + '2 is not a negative number', + '... validated unsuccessfully (got error)'); + +# check some meta-details + +my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen'); +isa_ok($natural_less_than_ten, 'Mouse::Meta::TypeConstraint'); + +ok($natural_less_than_ten->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural'); +ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number'); +ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String'); + +ok($natural_less_than_ten->has_message, '... it has a message'); + +ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)'); + +is($natural_less_than_ten->validate(15), + "The number '15' is not less than 10", + '... validated unsuccessfully (got error)'); + +my $natural = find_type_constraint('Natural'); +isa_ok($natural, 'Mouse::Meta::TypeConstraint'); + +ok($natural->is_subtype_of('Number'), '... Natural is a subtype of Number'); +ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String'); + +ok(!$natural->has_message, '... it does not have a message'); + +ok(!defined($natural->validate(5)), '... validated successfully (no error)'); + +is($natural->validate(-5), + "Validation failed for 'Natural' failed with value -5", + '... validated unsuccessfully (got error)'); + +my $string = find_type_constraint('String'); +isa_ok($string, 'Mouse::Meta::TypeConstraint'); + +ok($string->has_message, '... it does have a message'); + +ok(!defined($string->validate("Five")), '... validated successfully (no error)'); + +is($string->validate(5), +"This is not a string (5)", +'... validated unsuccessfully (got error)'); + +lives_ok { Mouse::Meta::Attribute->new('bob', isa => 'Spong') } + 'meta-attr construction ok even when type constraint utils loaded first'; + +# Test type constraint predicate return values. + +foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) { + ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint"); +} + +# Test adding things which don't look like types to the registry throws an exception + +my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry; +throws_ok {$r->add_type_constraint()} qr/not a valid type constraint/, '->add_type_constraint(undef) throws'; +throws_ok {$r->add_type_constraint('foo')} qr/not a valid type constraint/, '->add_type_constraint("foo") throws'; +throws_ok {$r->add_type_constraint(bless {}, 'SomeClass')} qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws'; + +# Test some specific things that in the past did not work, +# specifically weird variations on anon subtypes. + +{ + my $subtype = subtype as 'Str'; + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + # This test sucks but is the best we can do + is( $subtype->constraint->(), 1, + 'subtype has the null constraint' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype as 'ArrayRef[Num|Str]'; + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( ! $subtype->has_message, 'subtype has no message' ); +} + +{ + my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' }; + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' ); + is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); + ok( $subtype->has_message, 'subtype does have a message' ); +} + +# alternative sugar-less calling style which is documented as legit: +{ + my $subtype = subtype( 'MyStr', { as => 'Str' } ); + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, 'MyStr', 'name is MyStr' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str' } ); + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); +} + +{ + my $subtype = subtype( { as => 'Str', where => sub { /X/ } } ); + isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' ); + is( $subtype->name, '__ANON__', 'name is __ANON__' ); + is( $subtype->parent->name, 'Str', 'parent is Str' ); + ok( $subtype->check('FooX'), 'constraint accepts FooX' ); + ok( ! $subtype->check('Foo'), 'constraint reject Foo' ); +} + +{ + throws_ok { subtype 'Foo' } qr/cannot consist solely of a name/, + 'Cannot call subtype with a single string argument'; +} + +# Back-compat for being called without sugar. Previously, calling with +# sugar was indistinguishable from calling directly. + +{ + my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } ); + + ok( $type->check(5), '... this is a Num' ); + ok( ! $type->check('Foo'), '... this is not a Num' ); +} + +{ + # anon subtype + my $subtype = subtype( 'Number2', sub { $_ > 0 } ); + + ok( $subtype->check(5), '... this is a Natural'); + ok( ! $subtype->check(-5), '... this is not a Natural'); + ok( ! $subtype->check('Foo'), '... this is not a Natural'); +} + +{ + my $subtype = subtype( 'Natural2', 'Number2', sub { $_ > 0 } ); + + ok( $subtype->check(5), '... this is a Natural'); + ok( ! $subtype->check(-5), '... this is not a Natural'); + ok( ! $subtype->check('Foo'), '... this is not a Natural'); +} + +{ + my $subtype = subtype( 'Natural3', 'Number2' ); + + ok( $subtype->check(5), '... this is a Natural'); + ok( $subtype->check(-5), '... this is a Natural'); + ok( ! $subtype->check('Foo'), '... this is not a Natural'); +} + diff --git a/t/040_type_constraints/failing/002_util_type_constraints_export.t b/t/040_type_constraints/failing/002_util_type_constraints_export.t new file mode 100644 index 0000000..5d5612c --- /dev/null +++ b/t/040_type_constraints/failing/002_util_type_constraints_export.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + +{ + package Foo; + + use Mouse::Util::TypeConstraints; + + eval { + type MyRef => where { ref($_) }; + }; + ::ok( !$@, '... successfully exported &type to Foo package' ); + + eval { + subtype MyArrayRef => as MyRef => where { ref($_) eq 'ARRAY' }; + }; + ::ok( !$@, '... successfully exported &subtype to Foo package' ); + + Mouse::Util::TypeConstraints->export_type_constraints_as_functions(); + + ::ok( MyRef( {} ), '... Ref worked correctly' ); + ::ok( MyArrayRef( [] ), '... ArrayRef worked correctly' ); +} diff --git a/t/040_type_constraints/failing/003_util_std_type_constraints.t b/t/040_type_constraints/failing/003_util_std_type_constraints.t new file mode 100644 index 0000000..6ba81b7 --- /dev/null +++ b/t/040_type_constraints/failing/003_util_std_type_constraints.t @@ -0,0 +1,358 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 297; +use Test::Exception; + +use Scalar::Util (); + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +my $SCALAR_REF = \(my $var); + +no warnings 'once'; # << I *hates* that warning ... +my $GLOB = *GLOB_REF; +my $GLOB_REF = \$GLOB; + +my $fh; +open($fh, '<', $0) || die "Could not open $0 for the test"; + +my $fh_obj = bless {}, "IO::Handle"; # not really + +Mouse::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(defined Any(0), '... Any accepts anything'); +ok(defined Any(100), '... Any accepts anything'); +ok(defined Any(''), '... Any accepts anything'); +ok(defined Any('Foo'), '... Any accepts anything'); +ok(defined Any([]), '... Any accepts anything'); +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), '... 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'); + +ok(defined Item(0), '... Item is the base type, so accepts anything'); +ok(defined Item(100), '... Item is the base type, so accepts anything'); +ok(defined Item(''), '... Item is the base type, so accepts anything'); +ok(defined Item('Foo'), '... Item is the base type, so accepts anything'); +ok(defined Item([]), '... Item is the base type, so accepts anything'); +ok(defined Item({}), '... Item is the base type, so accepts anything'); +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), '... 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'); + +ok(defined Defined(0), '... Defined accepts anything which is defined'); +ok(defined Defined(100), '... Defined accepts anything which is defined'); +ok(defined Defined(''), '... Defined accepts anything which is defined'); +ok(defined Defined('Foo'), '... Defined accepts anything which is defined'); +ok(defined Defined([]), '... Defined accepts anything which is defined'); +ok(defined Defined({}), '... Defined accepts anything which is defined'); +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), '... 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'); + +ok(!defined Undef(0), '... Undef accepts anything which is not defined'); +ok(!defined Undef(100), '... Undef accepts anything which is not defined'); +ok(!defined Undef(''), '... Undef accepts anything which is not defined'); +ok(!defined Undef('Foo'), '... Undef accepts anything which is not defined'); +ok(!defined Undef([]), '... Undef accepts anything which is not defined'); +ok(!defined Undef({}), '... Undef accepts anything which is not defined'); +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), '... 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'); + +ok(defined Bool(0), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(defined Bool(1), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(!defined Bool(100), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(defined Bool(''), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(!defined Bool('Foo'), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(!defined Bool([]), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +ok(!defined Bool({}), '... Bool rejects anything which is not a 1 or 0 or "" or undef'); +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), '... 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'); + +ok(defined Value(0), '... Value accepts anything which is not a Ref'); +ok(defined Value(100), '... Value accepts anything which is not a Ref'); +ok(defined Value(''), '... Value accepts anything which is not a Ref'); +ok(defined Value('Foo'), '... Value accepts anything which is not a Ref'); +ok(!defined Value([]), '... Value rejects anything which is not a Value'); +ok(!defined Value({}), '... Value rejects anything which is not a Value'); +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), '... Value accepts anything which is not a Ref'); +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'); + +ok(!defined Ref(0), '... Ref accepts anything which is not a Value'); +ok(!defined Ref(100), '... Ref accepts anything which is not a Value'); +ok(!defined Ref(''), '... Ref accepts anything which is not a Value'); +ok(!defined Ref('Foo'), '... Ref accepts anything which is not a Value'); +ok(defined Ref([]), '... Ref rejects anything which is not a Ref'); +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 accepts anything which is not a Value'); +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'); + +ok(defined Int(0), '... Int accepts anything which is an Int'); +ok(defined Int(100), '... Int accepts anything which is an Int'); +ok(!defined Int(0.5), '... Int accepts anything which is not a Int'); +ok(!defined Int(100.01), '... Int accepts anything which is not a Int'); +ok(!defined Int(''), '... Int rejects anything which is not a Int'); +ok(!defined Int('Foo'), '... Int rejects anything which is not a Int'); +ok(!defined Int([]), '... Int rejects anything which is not a Int'); +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), '... 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'); + +ok(defined Num(0), '... Num accepts anything which is an Num'); +ok(defined Num(100), '... Num accepts anything which is an Num'); +ok(defined Num(0.5), '... Num accepts anything which is an Num'); +ok(defined Num(100.01), '... Num accepts anything which is an Num'); +ok(!defined Num(''), '... Num rejects anything which is not a Num'); +ok(!defined Num('Foo'), '... Num rejects anything which is not a Num'); +ok(!defined Num([]), '... Num rejects anything which is not a Num'); +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), '... 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'); + +ok(defined Str(0), '... Str accepts anything which is a Str'); +ok(defined Str(100), '... Str accepts anything which is a Str'); +ok(defined Str(''), '... Str accepts anything which is a Str'); +ok(defined Str('Foo'), '... Str accepts anything which is a Str'); +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), '... 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'); +ok(!defined Str(undef), '... Str rejects anything which is not a Str'); + +ok(!defined ScalarRef(0), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(100), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef(''), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef('Foo'), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef([]), '... ScalarRef rejects anything which is not a ScalarRef'); +ok(!defined ScalarRef({}), '... ScalarRef rejects anything which is not a ScalarRef'); +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), '... ScalarRef rejects anything which is not 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'); + +ok(!defined ArrayRef(0), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(100), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef(''), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(!defined ArrayRef('Foo'), '... ArrayRef rejects anything which is not a ArrayRef'); +ok(defined ArrayRef([]), '... ArrayRef accepts anything which is a ArrayRef'); +ok(!defined ArrayRef({}), '... ArrayRef rejects anything which is not a ArrayRef'); +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), '... 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'); + +ok(!defined HashRef(0), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(100), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef(''), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef('Foo'), '... HashRef rejects anything which is not a HashRef'); +ok(!defined HashRef([]), '... HashRef rejects anything which is not a HashRef'); +ok(defined HashRef({}), '... HashRef accepts anything which is a HashRef'); +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), '... 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'); + +ok(!defined CodeRef(0), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(100), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef(''), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef('Foo'), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef([]), '... CodeRef rejects anything which is not a CodeRef'); +ok(!defined CodeRef({}), '... CodeRef rejects anything which is not a CodeRef'); +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), '... 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'); + +ok(!defined RegexpRef(0), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef(100), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef(''), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef('Foo'), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef([]), '... RegexpRef rejects anything which is not a RegexpRef'); +ok(!defined RegexpRef({}), '... RegexpRef rejects anything which is not a RegexpRef'); +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), '... 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'); + +ok(!defined GlobRef(0), '... GlobRef rejects anything which is not a GlobRef'); +ok(!defined GlobRef(100), '... GlobRef rejects anything which is not a GlobRef'); +ok(!defined GlobRef(''), '... GlobRef rejects anything which is not a GlobRef'); +ok(!defined GlobRef('Foo'), '... GlobRef rejects anything which is not a GlobRef'); +ok(!defined GlobRef([]), '... GlobRef rejects anything which is not a GlobRef'); +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), '... GlobRef rejects 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($fh_obj), '... GlobRef rejects anything which is not 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), '... 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($fh_obj), '... 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'); +ok(!defined Object('Foo'), '... Object rejects anything which is not blessed'); +ok(!defined Object([]), '... Object rejects anything which is not blessed'); +ok(!defined Object({}), '... Object rejects anything which is not blessed'); +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), '... 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'); + +ok(!defined ClassName(0), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(100), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(''), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName('Baz'), '... ClassName rejects anything which is not a ClassName'); + +{ + package Quux::Wibble; # this makes Quux symbol table exist + + sub foo {} +} + +ok(!defined ClassName('Quux'), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName([]), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName({}), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(sub {}), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName($SCALAR_REF), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName($fh), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName($GLOB), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName($GLOB_REF), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(qr/../), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(bless {}, 'Foo'), '... ClassName rejects anything which is not a ClassName'); +ok(!defined ClassName(undef), '... ClassName rejects anything which is not a ClassName'); +ok(defined ClassName('UNIVERSAL'), '... ClassName accepts anything which is a ClassName'); +ok(defined ClassName('Quux::Wibble'), '... ClassName accepts anything which is a ClassName'); +ok(defined ClassName('Mouse::Meta::TypeConstraint'), '... ClassName accepts anything which is a ClassName'); + +ok(!defined RoleName(0), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName(100), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName(''), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName('Baz'), '... RoleName rejects anything which is not a RoleName'); + +{ + package Quux::Wibble::Role; # this makes Quux symbol table exist + use Mouse::Role; + sub foo {} +} + +ok(!defined RoleName('Quux'), '... RoleName rejects anything which is not a RoleName'); +ok(!defined RoleName([]), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName({}), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(sub {}), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($SCALAR_REF), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($fh), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($GLOB), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName($GLOB_REF), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(qr/../), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(bless {}, 'Foo'), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName(undef), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName('UNIVERSAL'), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName('Quux::Wibble'), '... Rolename rejects anything which is not a RoleName'); +ok(!defined RoleName('Mouse::Meta::TypeConstraint'), '... RoleName accepts anything which is a RoleName'); +ok(defined RoleName('Quux::Wibble::Role'), '... RoleName accepts anything which is a RoleName'); + +close($fh) || die "Could not close the filehandle $0 for test"; diff --git a/t/040_type_constraints/failing/004_util_find_type_constraint.t b/t/040_type_constraints/failing/004_util_find_type_constraint.t new file mode 100644 index 0000000..f7dcf1a --- /dev/null +++ b/t/040_type_constraints/failing/004_util_find_type_constraint.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 18; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +foreach my $type_name (qw( + Any + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + ArrayRef + HashRef + CodeRef + RegexpRef + Object + Role + )) { + is(find_type_constraint($type_name)->name, + $type_name, + '... got the right name for ' . $type_name); +} + +# TODO: +# add tests for is_subtype_of which confirm the hierarchy diff --git a/t/040_type_constraints/failing/005_util_type_coercion.t b/t/040_type_constraints/failing/005_util_type_coercion.t new file mode 100644 index 0000000..8b5a77a --- /dev/null +++ b/t/040_type_constraints/failing/005_util_type_coercion.t @@ -0,0 +1,102 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 26; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +{ + package HTTPHeader; + use Mouse; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + +coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + +Mouse::Util::TypeConstraints->export_type_constraints_as_functions(); + +my $header = HTTPHeader->new(); +isa_ok($header, 'HTTPHeader'); + +ok(Header($header), '... this passed the type test'); +ok(!Header([]), '... this did not pass the type test'); +ok(!Header({}), '... this did not pass the type test'); + +my $anon_type = subtype Object => where { $_->isa('HTTPHeader') }; + +lives_ok { + coerce $anon_type + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; +} 'coercion of anonymous subtype succeeds'; + +foreach my $coercion ( + find_type_constraint('Header')->coercion, + $anon_type->coercion + ) { + + isa_ok($coercion, 'Mouse::Meta::TypeCoercion'); + + { + my $coerced = $coercion->coerce([ 1, 2, 3 ]); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->array(), + [ 1, 2, 3 ], + '... got the right array'); + is($coerced->hash(), undef, '... nothing assigned to the hash'); + } + + { + my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); + isa_ok($coerced, 'HTTPHeader'); + + is_deeply( + $coerced->hash(), + { one => 1, two => 2, three => 3 }, + '... got the right hash'); + is($coerced->array(), undef, '... nothing assigned to the array'); + } + + { + my $scalar_ref = \(my $var); + my $coerced = $coercion->coerce($scalar_ref); + is($coerced, $scalar_ref, '... got back what we put in'); + } + + { + my $coerced = $coercion->coerce("Foo"); + is($coerced, "Foo", '... got back what we put in'); + } +} + +subtype 'StrWithTrailingX' + => as 'Str' + => where { /X$/ }; + +coerce 'StrWithTrailingX' + => from 'Str' + => via { $_ . 'X' }; + +my $tc = find_type_constraint('StrWithTrailingX'); +is($tc->coerce("foo"), "fooX", "coerce when needed"); +is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded"); diff --git a/t/040_type_constraints/failing/006_util_type_reloading.t b/t/040_type_constraints/failing/006_util_type_reloading.t new file mode 100644 index 0000000..4cde153 --- /dev/null +++ b/t/040_type_constraints/failing/006_util_type_reloading.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib 't/lib', 'lib'; + +use Test::More tests => 4; +use Test::Exception; + + + +$SIG{__WARN__} = sub { 0 }; + +eval { require Foo; }; +ok(!$@, '... loaded Foo successfully') || diag $@; + +delete $INC{'Foo.pm'}; + +eval { require Foo; }; +ok(!$@, '... re-loaded Foo successfully') || diag $@; + +eval { require Bar; }; +ok(!$@, '... loaded Bar successfully') || diag $@; + +delete $INC{'Bar.pm'}; + +eval { require Bar; }; +ok(!$@, '... re-loaded Bar successfully') || diag $@; \ No newline at end of file diff --git a/t/040_type_constraints/failing/007_util_more_type_coercion.t b/t/040_type_constraints/failing/007_util_more_type_coercion.t new file mode 100644 index 0000000..1cfa831 --- /dev/null +++ b/t/040_type_constraints/failing/007_util_more_type_coercion.t @@ -0,0 +1,117 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 25; +use Test::Exception; + + + +{ + package HTTPHeader; + use Mouse; + use Mouse::Util::TypeConstraints; + + coerce 'HTTPHeader' + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) }; + + coerce 'HTTPHeader' + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); + + package Engine; + use strict; + use warnings; + use Mouse; + + has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +} + +{ + my $engine = Engine->new(); + isa_ok($engine, 'Engine'); + + # try with arrays + + lives_ok { + $engine->header([ 1, 2, 3 ]); + } '... type was coerced without incident'; + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); + + # try with hash + + lives_ok { + $engine->header({ one => 1, two => 2, three => 3 }); + } '... type was coerced without incident'; + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); + + dies_ok { + $engine->header("Foo"); + } '... dies with the wrong type, even after coercion'; + + lives_ok { + $engine->header(HTTPHeader->new); + } '... lives with the right type, even after coercion'; +} + +{ + my $engine = Engine->new(header => [ 1, 2, 3 ]); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); +} + +{ + my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); +} + +{ + my $engine = Engine->new(header => HTTPHeader->new()); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + ok(!defined($engine->header->hash), '... no hash value set'); + ok(!defined($engine->header->array), '... no array value set'); +} + +dies_ok { + Engine->new(header => 'Foo'); +} '... dies correctly with bad params'; + +dies_ok { + Engine->new(header => \(my $var)); +} '... dies correctly with bad params'; + diff --git a/t/040_type_constraints/failing/008_union_types.t b/t/040_type_constraints/failing/008_union_types.t new file mode 100644 index 0000000..c0c9ce0 --- /dev/null +++ b/t/040_type_constraints/failing/008_union_types.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 35; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +my $Str = find_type_constraint('Str'); +isa_ok($Str, 'Mouse::Meta::TypeConstraint'); + +my $Undef = find_type_constraint('Undef'); +isa_ok($Undef, 'Mouse::Meta::TypeConstraint'); + +ok(!$Str->check(undef), '... Str cannot accept an Undef value'); +ok($Str->check('String'), '... Str can accept an String value'); +ok(!$Undef->check('String'), '... Undef cannot accept an Str value'); +ok($Undef->check(undef), '... Undef can accept an Undef value'); + +my $Str_or_Undef = Mouse::Meta::TypeConstraint::Union->new(type_constraints => [$Str, $Undef]); +isa_ok($Str_or_Undef, 'Mouse::Meta::TypeConstraint::Union'); + +ok($Str_or_Undef->check(undef), '... (Str | Undef) can accept an Undef value'); +ok($Str_or_Undef->check('String'), '... (Str | Undef) can accept a String value'); + +ok($Str_or_Undef->is_a_type_of($Str), "subtype of Str"); +ok($Str_or_Undef->is_a_type_of($Undef), "subtype of Undef"); + +ok( !$Str_or_Undef->equals($Str), "not equal to Str" ); +ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" ); +ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint::Union->new(type_constraints => [ $Str, $Undef ])), "equal to clone" ); +ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint::Union->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" ); + +ok( !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), "not type of non existant type" ); +ok( !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of non existant type" ); + +# another .... + +my $ArrayRef = find_type_constraint('ArrayRef'); +isa_ok($ArrayRef, 'Mouse::Meta::TypeConstraint'); + +my $HashRef = find_type_constraint('HashRef'); +isa_ok($HashRef, 'Mouse::Meta::TypeConstraint'); + +ok($ArrayRef->check([]), '... ArrayRef can accept an [] value'); +ok(!$ArrayRef->check({}), '... ArrayRef cannot accept an {} value'); +ok($HashRef->check({}), '... HashRef can accept an {} value'); +ok(!$HashRef->check([]), '... HashRef cannot accept an [] value'); + +my $HashOrArray = Mouse::Meta::TypeConstraint::Union->new(type_constraints => [$ArrayRef, $HashRef]); +isa_ok($HashOrArray, 'Mouse::Meta::TypeConstraint::Union'); + +ok($HashOrArray->check([]), '... (ArrayRef | HashRef) can accept []'); +ok($HashOrArray->check({}), '... (ArrayRef | HashRef) can accept {}'); + +ok(!$HashOrArray->check(\(my $var1)), '... (ArrayRef | HashRef) cannot accept scalar refs'); +ok(!$HashOrArray->check(sub {}), '... (ArrayRef | HashRef) cannot accept code refs'); +ok(!$HashOrArray->check(50), '... (ArrayRef | HashRef) cannot accept Numbers'); + +diag $HashOrArray->validate([]); + +ok(!defined($HashOrArray->validate([])), '... (ArrayRef | HashRef) can accept []'); +ok(!defined($HashOrArray->validate({})), '... (ArrayRef | HashRef) can accept {}'); + +like($HashOrArray->validate(\(my $var2)), +qr/Validation failed for \'ArrayRef\' failed with value SCALAR\(0x.+?\) and Validation failed for \'HashRef\' failed with value SCALAR\(0x.+?\) in \(ArrayRef\|HashRef\)/, +'... (ArrayRef | HashRef) cannot accept scalar refs'); + +like($HashOrArray->validate(sub {}), +qr/Validation failed for \'ArrayRef\' failed with value CODE\(0x.+?\) and Validation failed for \'HashRef\' failed with value CODE\(0x.+?\) in \(ArrayRef\|HashRef\)/, +'... (ArrayRef | HashRef) cannot accept code refs'); + +is($HashOrArray->validate(50), +'Validation failed for \'ArrayRef\' failed with value 50 and Validation failed for \'HashRef\' failed with value 50 in (ArrayRef|HashRef)', +'... (ArrayRef | HashRef) cannot accept Numbers'); + diff --git a/t/040_type_constraints/failing/009_union_types_and_coercions.t b/t/040_type_constraints/failing/009_union_types_and_coercions.t new file mode 100644 index 0000000..5dd13ea --- /dev/null +++ b/t/040_type_constraints/failing/009_union_types_and_coercions.t @@ -0,0 +1,162 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +BEGIN { + eval "use IO::String; use IO::File;"; + plan skip_all => "IO::String and IO::File are required for this test" if $@; + plan tests => 28; +} + + + +{ + package Email::Mouse; + use Mouse; + use Mouse::Util::TypeConstraints; + + use IO::String; + + our $VERSION = '0.01'; + + # create subtype for IO::String + + subtype 'IO::String' + => as 'Object' + => where { $_->isa('IO::String') }; + + coerce 'IO::String' + => from 'Str' + => via { IO::String->new($_) }, + => from 'ScalarRef', + => via { IO::String->new($_) }; + + # create subtype for IO::File + + subtype 'IO::File' + => as 'Object' + => where { $_->isa('IO::File') }; + + coerce 'IO::File' + => from 'FileHandle' + => via { bless $_, 'IO::File' }; + + # create the alias + + subtype 'IO::StringOrFile' => as 'IO::String | IO::File'; + + # attributes + + has 'raw_body' => ( + is => 'rw', + isa => 'IO::StringOrFile', + coerce => 1, + default => sub { IO::String->new() }, + ); + + sub as_string { + my ($self) = @_; + my $fh = $self->raw_body(); + return do { local $/; <$fh> }; + } +} + +{ + my $email = Email::Mouse->new; + isa_ok($email, 'Email::Mouse'); + + isa_ok($email->raw_body, 'IO::String'); + + is($email->as_string, undef, '... got correct empty string'); +} + +{ + my $email = Email::Mouse->new(raw_body => '... this is my body ...'); + isa_ok($email, 'Email::Mouse'); + + 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'); +} + +{ + my $str = '... this is my body (ref) ...'; + + my $email = Email::Mouse->new(raw_body => \$str); + isa_ok($email, 'Email::Mouse'); + + 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'); +} + +{ + my $io_str = IO::String->new('... this is my body (IO::String) ...'); + + my $email = Email::Mouse->new(raw_body => $io_str); + isa_ok($email, 'Email::Mouse'); + + 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'); +} + +{ + my $fh; + + open($fh, '<', $0) || die "Could not open $0"; + + my $email = Email::Mouse->new(raw_body => $fh); + isa_ok($email, 'Email::Mouse'); + + isa_ok($email->raw_body, 'IO::File'); + + close($fh); +} + +{ + my $fh = IO::File->new($0); + + my $email = Email::Mouse->new(raw_body => $fh); + isa_ok($email, 'Email::Mouse'); + + isa_ok($email->raw_body, 'IO::File'); + is($email->raw_body, $fh, '... and it is the one we expected'); +} + + + diff --git a/t/040_type_constraints/failing/010_misc_type_tests.t b/t/040_type_constraints/failing/010_misc_type_tests.t new file mode 100644 index 0000000..43fcebc --- /dev/null +++ b/t/040_type_constraints/failing/010_misc_type_tests.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +# subtype 'aliasing' ... + +lives_ok { + subtype 'Numb3rs' => as 'Num'; +} '... create bare subtype fine'; + +my $numb3rs = find_type_constraint('Numb3rs'); +isa_ok($numb3rs, 'Mouse::Meta::TypeConstraint'); + +# subtype with unions + +{ + package Test::Mouse::Meta::TypeConstraint::Union; + + use overload '""' => sub {'Broken|Test'}, fallback => 1; + use Mouse; + + extends 'Mouse::Meta::TypeConstraint'; +} + +my $dummy_instance = Test::Mouse::Meta::TypeConstraint::Union->new; + +ok $dummy_instance => "Created Instance"; + +isa_ok $dummy_instance, + 'Test::Mouse::Meta::TypeConstraint::Union' => 'isa correct type'; + +is "$dummy_instance", "Broken|Test" => + 'Got expected stringification result'; + +my $subtype1 = subtype 'New1' => as $dummy_instance; + +ok $subtype1 => 'made a subtype from our type object'; + +my $subtype2 = subtype 'New2' => as $subtype1; + +ok $subtype2 => 'made a subtype of our subtype'; + +# assert_valid + +{ + my $type = find_type_constraint('Num'); + + my $ok_1 = eval { $type->assert_valid(1); }; + ok($ok_1, "we can assert_valid that 1 is of type $type"); + + my $ok_2 = eval { $type->assert_valid('foo'); }; + my $error = $@; + ok(! $ok_2, "'foo' is not of type $type"); + like( + $error, + qr{validation failed for .\Q$type\E.}i, + "correct error thrown" + ); +} diff --git a/t/040_type_constraints/failing/011_container_type_constraint.t b/t/040_type_constraints/failing/011_container_type_constraint.t new file mode 100644 index 0000000..82f1b99 --- /dev/null +++ b/t/040_type_constraints/failing/011_container_type_constraint.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 24; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); + use_ok('Mouse::Meta::TypeConstraint::Parameterized'); +} + +# Array of Ints + +my $array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Hash of Ints + +my $hash_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($hash_of_ints->check({ one => 1, two => 2, three => 3 }), '... { one => 1, two => 2, three => 3 } passed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', 3 => 'three' }), '... { 1 => one, 2 => two, 3 => three } failed successfully'); +ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', three => 3 }), '... { 1 => one, 2 => two, three => 3 } failed successfully'); + +ok(!$hash_of_ints->check(1), '... 1 failed successfully'); +ok(!$hash_of_ints->check([]), '... [] failed successfully'); +ok(!$hash_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[ArrayRef[Int]]', + parent => find_type_constraint('ArrayRef'), + type_parameter => $array_of_ints, +); +isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +{ + my $anon_type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Foo]'); + isa_ok( $anon_type, 'Mouse::Meta::TypeConstraint::Parameterized' ); + + my $param_type = $anon_type->type_parameter; + isa_ok( $param_type, 'Mouse::Meta::TypeConstraint::Class' ); +} diff --git a/t/040_type_constraints/failing/012_container_type_coercion.t b/t/040_type_constraints/failing/012_container_type_coercion.t new file mode 100644 index 0000000..e344587 --- /dev/null +++ b/t/040_type_constraints/failing/012_container_type_coercion.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); + use_ok('Mouse::Meta::TypeConstraint::Parameterized'); +} + +my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry; + +# Array of Ints + +my $array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'ArrayRef[Int]', + parent => find_type_constraint('ArrayRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint'); + +$r->add_type_constraint($array_of_ints); + +is(find_type_constraint('ArrayRef[Int]'), $array_of_ints, '... found the type we just added'); + +# Hash of Ints + +my $hash_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'HashRef[Int]', + parent => find_type_constraint('HashRef'), + type_parameter => find_type_constraint('Int'), +); +isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint'); + +$r->add_type_constraint($hash_of_ints); + +is(find_type_constraint('HashRef[Int]'), $hash_of_ints, '... found the type we just added'); + +## now attempt a coercion + +{ + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + + coerce 'ArrayRef[Int]' + => from 'HashRef[Int]' + => via { [ values %$_ ] }; + + has 'bar' => ( + is => 'ro', + isa => 'ArrayRef[Int]', + coerce => 1, + ); + +} + +my $foo = Foo->new(bar => { one => 1, two => 2, three => 3 }); +isa_ok($foo, 'Foo'); + +is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!'); + + diff --git a/t/040_type_constraints/failing/013_advanced_type_creation.t b/t/040_type_constraints/failing/013_advanced_type_creation.t new file mode 100644 index 0000000..7610baa --- /dev/null +++ b/t/040_type_constraints/failing/013_advanced_type_creation.t @@ -0,0 +1,101 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 33; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); + use_ok('Mouse::Meta::TypeConstraint::Parameterized'); +} + +my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry; + +## Containers in unions ... + +# Array of Ints or Strings + +my $array_of_ints_or_strings = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int|Str]'); +isa_ok($array_of_ints_or_strings, 'Mouse::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_strings->check([ 'one', 'two', 'three' ]), '... this passed the type check'); + +ok(!$array_of_ints_or_strings->check([ 1, [], 'three' ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_strings); + +# Array of Ints or HashRef + +my $array_of_ints_or_hash_ref = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int | HashRef]'); +isa_ok($array_of_ints_or_hash_ref, 'Mouse::Meta::TypeConstraint::Parameterized'); + +ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check'); +ok($array_of_ints_or_hash_ref->check([ {}, {}, {} ]), '... this passed the type check'); + +ok(!$array_of_ints_or_hash_ref->check([ {}, [], 3 ]), '... this didnt pass the type check'); + +$r->add_type_constraint($array_of_ints_or_hash_ref); + +# union of Arrays of Str | Int or Arrays of Int | Hash + +# we can't build this using the simplistic parser +# we have, so we have to do it by hand - SL + +my $pure_insanity = Mouse::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int|Str] | ArrayRef[Int | HashRef]'); +isa_ok($pure_insanity, 'Mouse::Meta::TypeConstraint::Union'); + +ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check'); +ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check'); + +ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check'); +ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check'); + +## Nested Containers ... + +# Array of Ints + +my $array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int]'); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); +ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); +ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); + +ok(!$array_of_ints->check(1), '... 1 failed successfully'); +ok(!$array_of_ints->check({}), '... {} failed successfully'); +ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); + +# Array of Array of Ints + +my $array_of_array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[Int]]'); +isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ 4, 5, 6 ]] +), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); +ok(!$array_of_array_of_ints->check( + [[ 1, 2, 3 ], [ qw/foo bar/ ]] +), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); + +# Array of Array of Array of Ints + +my $array_of_array_of_array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]'); +isa_ok($array_of_array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized'); +isa_ok($array_of_array_of_array_of_ints, 'Mouse::Meta::TypeConstraint'); + +ok($array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] +), '... [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] passed successfully'); +ok(!$array_of_array_of_array_of_ints->check( + [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] +), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully'); + + + diff --git a/t/040_type_constraints/failing/014_type_notation_parser.t b/t/040_type_constraints/failing/014_type_notation_parser.t new file mode 100644 index 0000000..b2821c1 --- /dev/null +++ b/t/040_type_constraints/failing/014_type_notation_parser.t @@ -0,0 +1,105 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 41; + +BEGIN { + use_ok("Mouse::Util::TypeConstraints"); +} + +=pod + +This is a good candidate for LectroTest +Volunteers welcome :) + +=cut + +## check the containers + +ok(Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a container (' . $_ . ')') + for ( + 'ArrayRef[Foo]', + 'ArrayRef[Foo | Int]', + 'ArrayRef[ArrayRef[Int]]', + 'ArrayRef[ArrayRef[Int | Foo]]', + 'ArrayRef[ArrayRef[Int|Str]]', +); + +ok(!Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint($_), + '... this correctly detected a non-container (' . $_ . ')') + for ( + 'ArrayRef[]', + 'ArrayRef[Foo]Bar', +); + +{ + my %split_tests = ( + 'ArrayRef[Foo]' => [ 'ArrayRef', 'Foo' ], + 'ArrayRef[Foo | Int]' => [ 'ArrayRef', 'Foo | Int' ], + 'ArrayRef[Foo|Int]' => [ 'ArrayRef', 'Foo|Int' ], + # these will get processed with recusion, + # so we only need to detect it once + 'ArrayRef[ArrayRef[Int]]' => [ 'ArrayRef', 'ArrayRef[Int]' ], + 'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ], + 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ], + ); + + is_deeply( + [ Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint($_) ], + $split_tests{$_}, + '... this correctly split the container (' . $_ . ')' + ) for keys %split_tests; +} + +## now for the unions + +ok(Mouse::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected union (' . $_ . ')') + for ( + 'Int | Str', + 'Int|Str', + 'ArrayRef[Foo] | Int', + 'ArrayRef[Foo]|Int', + 'Int | ArrayRef[Foo]', + 'Int|ArrayRef[Foo]', + 'ArrayRef[Foo | Int] | Str', + 'ArrayRef[Foo|Int]|Str', + 'Str | ArrayRef[Foo | Int]', + 'Str|ArrayRef[Foo|Int]', + 'Some|Silly|Name|With|Pipes | Int', + 'Some|Silly|Name|With|Pipes|Int', +); + +ok(!Mouse::Util::TypeConstraints::_detect_type_constraint_union($_), + '... this correctly detected a non-union (' . $_ . ')') + for ( + 'Int', + 'ArrayRef[Foo | Int]', + 'ArrayRef[Foo|Int]', +); + +{ + my %split_tests = ( + 'Int | Str' => [ 'Int', 'Str' ], + 'Int|Str' => [ 'Int', 'Str' ], + 'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ], + 'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'Int|ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], + 'ArrayRef[Foo | Int] | Str' => [ 'ArrayRef[Foo | Int]', 'Str' ], + 'ArrayRef[Foo|Int]|Str' => [ 'ArrayRef[Foo|Int]', 'Str' ], + 'Str | ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ], + 'Str|ArrayRef[Foo|Int]' => [ 'Str', 'ArrayRef[Foo|Int]' ], + 'Some|Silly|Name|With|Pipes | Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + 'Some|Silly|Name|With|Pipes|Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], + ); + + is_deeply( + [ Mouse::Util::TypeConstraints::_parse_type_constraint_union($_) ], + $split_tests{$_}, + '... this correctly split the union (' . $_ . ')' + ) for keys %split_tests; +} diff --git a/t/040_type_constraints/failing/015_enum.t b/t/040_type_constraints/failing/015_enum.t new file mode 100644 index 0000000..940a341 --- /dev/null +++ b/t/040_type_constraints/failing/015_enum.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Scalar::Util (); + +use Mouse::Util::TypeConstraints; + +enum Letter => 'a'..'z', 'A'..'Z'; +enum Language => 'Perl 5', 'Perl 6', 'PASM', 'PIR'; # any others? ;) +enum Metacharacter => ['*', '+', '?', '.', '|', '(', ')', '[', ']', '\\']; + +my @valid_letters = ('a'..'z', 'A'..'Z'); + +my @invalid_letters = qw/ab abc abcd/; +push @invalid_letters, qw/0 4 9 ~ @ $ %/; +push @invalid_letters, qw/l33t st3v4n 3num/; + +my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR'); +my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++'); +# note that "perl 5" is invalid because case now matters + +my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\'); +my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/; +push @invalid_metacharacters, qw/.* fish(sticks)? atreides/; +push @invalid_metacharacters, '^1?$|^(11+?)\1+$'; + +plan tests => @valid_letters + @invalid_letters + + @valid_languages + @invalid_languages + + @valid_metacharacters + @invalid_metacharacters + + @valid_languages + 10; + +Mouse::Util::TypeConstraints->export_type_constraints_as_functions(); + +ok(Letter($_), "'$_' is a letter") for @valid_letters; +ok(!Letter($_), "'$_' is not a letter") for @invalid_letters; + +ok(Language($_), "'$_' is a language") for @valid_languages; +ok(!Language($_), "'$_' is not a language") for @invalid_languages; + +ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters; +ok(!Metacharacter($_), "'$_' is not a metacharacter") + for @invalid_metacharacters; + +# check anon enums + +my $anon_enum = enum \@valid_languages; +isa_ok($anon_enum, 'Mouse::Meta::TypeConstraint'); + +is($anon_enum->name, '__ANON__', '... got the right name'); +is($anon_enum->parent->name, 'Str', '... got the right parent name'); + +ok($anon_enum->check($_), "'$_' is a language") for @valid_languages; + + +ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" ); +ok( $anon_enum->equals( $anon_enum ), "equals itself" ); +ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" ); + +ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object'); +ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object'); + +ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type'); +ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type'); + diff --git a/t/040_type_constraints/failing/016_subtyping_parameterized_types.t b/t/040_type_constraints/failing/016_subtyping_parameterized_types.t new file mode 100644 index 0000000..2fa5f60 --- /dev/null +++ b/t/040_type_constraints/failing/016_subtyping_parameterized_types.t @@ -0,0 +1,121 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 39; +use Test::Exception; + +BEGIN { + use_ok("Mouse::Util::TypeConstraints"); +} + +lives_ok { + subtype 'MySpecialHash' => as 'HashRef[Int]'; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MySpecialHash'); + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Mouse::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Mouse::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated {one=>1, two=>2} correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals( $t->parent ), "not equal to parent" ); + ok( $t->parent->equals( $t->parent ), "parent equals to self" ); + + ok( !$t->is_a_type_of("ThisTypeDoesNotExist"), "not a non existant type" ); + ok( !$t->is_subtype_of("ThisTypeDoesNotExist"), "not a subtype of a non existant type" ); +} + +lives_ok { + subtype 'MySpecialHashExtended' + => as 'HashRef[Int]' + => where { + # all values are less then 10 + (scalar grep { $_ < 10 } values %{$_}) ? 1 : undef + }; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MySpecialHashExtended'); + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHashExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Mouse::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Mouse::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ zero => 10, one => 11, two => 12 }), '... validated { zero => 10, one => 11, two => 12 } correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); +} + +lives_ok { + subtype 'MyNonSpecialHash' + => as "HashRef" + => where { keys %$_ == 3 }; +}; + +{ + my $t = find_type_constraint('MyNonSpecialHash'); + + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + isa_ok($t, 'Mouse::Meta::TypeConstraint::Parameterizable'); + + ok( $t->check({ one => 1, two => "foo", three => [] }), "validated" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + my $t = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('MyNonSpecialHash[Int]'); + + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + ok( $t->check({ one => 1, two => 2, three => 3 }), "validated" ); + ok( !$t->check({ one => 1, two => "foo", three => [] }), "failed" ); + ok( !$t->check({ one => 1 }), "failed" ); +} + +{ + ## Because to throw errors in M:M:Parameterizable needs Mouse loaded in + ## order to throw errors. In theory the use Mouse belongs to that class + ## but when I put it there causes all sorts or trouble. In theory this is + ## never a real problem since you are likely to use Mouse somewhere when you + ## are creating type constraints. + use Mouse (); + + my $MyArrayRefInt = subtype 'MyArrayRefInt', + as 'ArrayRef[Int]'; + + my $BiggerInt = subtype 'BiggerInt', + as 'Int', + where {$_>10}; + + my $SubOfMyArrayRef = subtype 'SubOfMyArrayRef', + as 'MyArrayRefInt[BiggerInt]'; + + ok $MyArrayRefInt->check([1,2,3]), '[1,2,3] is okay'; + ok ! $MyArrayRefInt->check(["a","b"]), '["a","b"] is not'; + ok $BiggerInt->check(100), '100 is big enough'; + ok ! $BiggerInt->check(5), '5 is big enough'; + ok $SubOfMyArrayRef->check([15,20,25]), '[15,20,25] is a bunch of big ints'; + ok ! $SubOfMyArrayRef->check([15,5,25]), '[15,5,25] is NOT a bunch of big ints'; + + throws_ok sub { + my $SubOfMyArrayRef = subtype 'SubSubOfMyArrayRef', + as 'SubOfMyArrayRef[Str]'; + }, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter'; +} diff --git a/t/040_type_constraints/failing/017_subtyping_union_types.t b/t/040_type_constraints/failing/017_subtyping_union_types.t new file mode 100644 index 0000000..85768ac --- /dev/null +++ b/t/040_type_constraints/failing/017_subtyping_union_types.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 21; +use Test::Exception; + +BEGIN { + use_ok("Mouse::Util::TypeConstraints"); +} + +lives_ok { + subtype 'MyCollections' => as 'ArrayRef | HashRef'; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MyCollections'); + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + is($t->name, 'MyCollections', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Mouse::Meta::TypeConstraint::Union'); + isa_ok($p, 'Mouse::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok($t->check([]), '... validated it correctly'); + ok($t->check({}), '... validated it correctly'); + ok(!$t->check(1), '... validated it correctly'); +} + +lives_ok { + subtype 'MyCollectionsExtended' + => as 'ArrayRef|HashRef' + => where { + if (ref($_) eq 'ARRAY') { + return if scalar(@$_) < 2; + } + elsif (ref($_) eq 'HASH') { + return if scalar(keys(%$_)) < 2; + } + 1; + }; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MyCollectionsExtended'); + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + is($t->name, 'MyCollectionsExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Mouse::Meta::TypeConstraint::Union'); + isa_ok($p, 'Mouse::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); + + ok(!$t->check([]), '... validated it correctly'); + ok($t->check([1, 2]), '... validated it correctly'); + + ok(!$t->check({}), '... validated it correctly'); + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + + ok(!$t->check(1), '... validated it correctly'); +} + + diff --git a/t/040_type_constraints/failing/018_custom_parameterized_types.t b/t/040_type_constraints/failing/018_custom_parameterized_types.t new file mode 100644 index 0000000..c00bda9 --- /dev/null +++ b/t/040_type_constraints/failing/018_custom_parameterized_types.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 28; +use Test::Exception; + +BEGIN { + use_ok("Mouse::Util::TypeConstraints"); + use_ok('Mouse::Meta::TypeConstraint::Parameterized'); +} + +lives_ok { + subtype 'AlphaKeyHash' => as 'HashRef' + => where { + # no keys match non-alpha + (grep { /[^a-zA-Z]/ } keys %$_) == 0 + }; +} '... created the subtype special okay'; + +lives_ok { + subtype 'Trihash' => as 'AlphaKeyHash' + => where { + keys(%$_) == 3 + }; +} '... created the subtype special okay'; + +lives_ok { + subtype 'Noncon' => as 'Item'; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('AlphaKeyHash'); + isa_ok($t, 'Mouse::Meta::TypeConstraint'); + + is($t->name, 'AlphaKeyHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Mouse::Meta::TypeConstraint'); + + is($p->name, 'HashRef', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); + + ok( $t->equals($t), "equals to self" ); + ok( !$t->equals($t->parent), "not equal to parent" ); +} + +my $hoi = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]'); + +ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); +ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly'); +ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly'); + +ok( $hoi->equals($hoi), "equals to self" ); +ok( !$hoi->equals($hoi->parent), "equals to self" ); +ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" ); +ok( $hoi->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$hoi->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" ); + +my $th = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]'); + +ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly'); +ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly'); +ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly'); +ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly'); + +dies_ok { + Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'Str[Int]', + parent => find_type_constraint('Str'), + type_parameter => find_type_constraint('Int'), + ); +} 'non-containers cannot be parameterized'; + +dies_ok { + Mouse::Meta::TypeConstraint::Parameterized->new( + name => 'Noncon[Int]', + parent => find_type_constraint('Noncon'), + type_parameter => find_type_constraint('Int'), + ); +} 'non-containers cannot be parameterized'; + diff --git a/t/040_type_constraints/failing/019_coerced_parameterized_types.t b/t/040_type_constraints/failing/019_coerced_parameterized_types.t new file mode 100644 index 0000000..5b57ad3 --- /dev/null +++ b/t/040_type_constraints/failing/019_coerced_parameterized_types.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; + +BEGIN { + use_ok("Mouse::Util::TypeConstraints"); + use_ok('Mouse::Meta::TypeConstraint::Parameterized'); +} + +BEGIN { + package MyList; + sub new { + my $class = shift; + bless { items => \@_ }, $class; + } + + sub items { + my $self = shift; + return @{ $self->{items} }; + } +} + +subtype 'MyList' => as 'Object' => where { $_->isa('MyList') }; + +lives_ok { + coerce 'ArrayRef' + => from 'MyList' + => via { [ $_->items ] } +} '... created the coercion okay'; + +my $mylist = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('MyList[Int]'); + +ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)'); +ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$mylist->check([10]), '... validated it correctly (fail)'); + +subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 }; + +# XXX: get this to work *without* the declaration. I suspect it'll be a new +# method in Mouse::Meta::TypeCoercion that will look at the parents of the +# coerced type as well. but will that be too "action at a distance"-ey? +lives_ok { + coerce 'ArrayRef' + => from 'EvenList' + => via { [ $_->items ] } +} '... created the coercion okay'; + +my $evenlist = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('EvenList[Int]'); + +ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)'); +ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)'); +ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); +ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)'); + diff --git a/t/040_type_constraints/failing/020_class_type_constraint.t b/t/040_type_constraints/failing/020_class_type_constraint.t new file mode 100644 index 0000000..05a9320 --- /dev/null +++ b/t/040_type_constraints/failing/020_class_type_constraint.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 20; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +{ + package Gorch; + use Mouse; + + package Bar; + use Mouse; + + package Foo; + use Mouse; + + extends qw(Bar Gorch); + +} + +lives_ok { class_type 'Beep' } 'class_type keywork works'; +lives_ok { class_type('Boop', message { "${_} is not a Boop" }) } + 'class_type keywork works with message'; + +my $type = find_type_constraint("Foo"); + +is( $type->class, "Foo", "class attribute" ); + +ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + +ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + +ok( $type->is_subtype_of("Object"), "subtype of Object" ); + +ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of undefined type" ); +ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of undefined type" ); + +ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" ); +ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" ); +ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch"); + +ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" ); +my $boop = find_type_constraint("Boop"); +ok( $boop->has_message, 'Boop has a message'); +my $error = $boop->get_message(Foo->new); +like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + +ok( $type->equals($type), "equals self" ); +ok( $type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" ); +ok( $type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" ); +ok( !$type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" ); +ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" ); + diff --git a/t/040_type_constraints/failing/021_maybe_type_constraint.t b/t/040_type_constraints/failing/021_maybe_type_constraint.t new file mode 100644 index 0000000..85fcff9 --- /dev/null +++ b/t/040_type_constraints/failing/021_maybe_type_constraint.t @@ -0,0 +1,133 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 36; +use Test::Exception; + +use Mouse::Util::TypeConstraints; + +my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]'); +isa_ok($type, 'Mouse::Meta::TypeConstraint'); +isa_ok($type, 'Mouse::Meta::TypeConstraint::Parameterized'); + +ok( $type->equals($type), "equals self" ); +ok( !$type->equals($type->parent), "not equal to parent" ); +ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" ); +ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" ); +ok( $type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); +ok( !$type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" ); +ok( !$type->equals( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" ); + +ok($type->check(10), '... checked type correctly (pass)'); +ok($type->check(undef), '... checked type correctly (pass)'); +ok(!$type->check('Hello World'), '... checked type correctly (fail)'); +ok(!$type->check([]), '... checked type correctly (fail)'); + +{ + package Bar; + use Mouse; + + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + + has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1); + has 'bar' => (is => 'rw', isa => class_type('Bar')); + has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar'))); +} + +lives_ok { + Foo->new(arr => [], bar => Bar->new); +} '... Bar->new isa Bar'; + +dies_ok { + Foo->new(arr => [], bar => undef); +} '... undef isnta Bar'; + +lives_ok { + Foo->new(arr => [], maybe_bar => Bar->new); +} '... Bar->new isa maybe(Bar)'; + +lives_ok { + Foo->new(arr => [], maybe_bar => undef); +} '... undef isa maybe(Bar)'; + +dies_ok { + Foo->new(arr => [], maybe_bar => 1); +} '... 1 isnta maybe(Bar)'; + +lives_ok { + Foo->new(arr => []); +} '... it worked!'; + +lives_ok { + Foo->new(arr => undef); +} '... it worked!'; + +dies_ok { + Foo->new(arr => 100); +} '... failed the type check'; + +dies_ok { + Foo->new(arr => 'hello world'); +} '... failed the type check'; + + +{ + package Test::MouseX::Types::Maybe; + use Mouse; + + has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]'); + has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]'); + has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]'); + has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]'); + has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]'); +} + +ok my $obj = Test::MouseX::Types::Maybe->new + => 'Create good test object'; + +## Maybe[Int] + +ok my $Maybe_Int = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]') + => 'made TC Maybe[Int]'; + +ok $Maybe_Int->check(1) + => 'passed (1)'; + +ok $obj->Maybe_Int(1) + => 'assigned (1)'; + +ok $Maybe_Int->check() + => 'passed ()'; + +ok $obj->Maybe_Int() + => 'assigned ()'; + +ok $Maybe_Int->check(0) + => 'passed (0)'; + +ok defined $obj->Maybe_Int(0) + => 'assigned (0)'; + +ok $Maybe_Int->check(undef) + => 'passed (undef)'; + +ok sub {$obj->Maybe_Int(undef); 1}->() + => 'assigned (undef)'; + +ok !$Maybe_Int->check("") + => 'failed ("")'; + +throws_ok sub { $obj->Maybe_Int("") }, + qr/Attribute \(Maybe_Int\) does not pass the type constraint/ + => 'failed assigned ("")'; + +ok !$Maybe_Int->check("a") + => 'failed ("a")'; + +throws_ok sub { $obj->Maybe_Int("a") }, + qr/Attribute \(Maybe_Int\) does not pass the type constraint/ + => 'failed assigned ("a")'; diff --git a/t/040_type_constraints/failing/022_custom_type_errors.t b/t/040_type_constraints/failing/022_custom_type_errors.t new file mode 100644 index 0000000..38757e7 --- /dev/null +++ b/t/040_type_constraints/failing/022_custom_type_errors.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; +use Test::Exception; + +{ + package Animal; + use Mouse; + use Mouse::Util::TypeConstraints; + + subtype 'Natural' => as 'Int' => where { $_ > 0 } => + message {"This number ($_) is not a positive integer!"}; + + subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => + message {"This number ($_) is not less than ten!"}; + + has leg_count => ( + is => 'rw', + isa => 'NaturalLessThanTen', + lazy => 1, + default => 0, + ); +} + +lives_ok { my $goat = Animal->new( leg_count => 4 ) } +'... no errors thrown, value is good'; +lives_ok { my $spider = Animal->new( leg_count => 8 ) } +'... no errors thrown, value is good'; + +throws_ok { my $fern = Animal->new( leg_count => 0 ) } +qr/This number \(0\) is not less than ten!/, + 'gave custom supertype error message on new'; + +throws_ok { my $centipede = Animal->new( leg_count => 30 ) } +qr/This number \(30\) is not less than ten!/, + 'gave custom subtype error message on new'; + +my $chimera; +lives_ok { $chimera = Animal->new( leg_count => 4 ) } +'... no errors thrown, value is good'; + +throws_ok { $chimera->leg_count(0) } +qr/This number \(0\) is not less than ten!/, + 'gave custom supertype error message on set to 0'; + +throws_ok { $chimera->leg_count(16) } +qr/This number \(16\) is not less than ten!/, + 'gave custom subtype error message on set to 16'; + +my $gimp = eval { Animal->new() }; +is( $@, '', '... no errors thrown, value is good' ); + +throws_ok { $gimp->leg_count } +qr/This number \(0\) is not less than ten!/, + 'gave custom supertype error message on lazy set to 0'; + diff --git a/t/040_type_constraints/failing/023_types_and_undef.t b/t/040_type_constraints/failing/023_types_and_undef.t new file mode 100644 index 0000000..e504eb3 --- /dev/null +++ b/t/040_type_constraints/failing/023_types_and_undef.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 54; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + + use Scalar::Util (); + + type Number + => where { defined($_) && !ref($_) && Scalar::Util::looks_like_number($_) }; + + type String + => where { defined($_) && !ref($_) && !Scalar::Util::looks_like_number($_) }; + + has vUndef => ( is => 'rw', isa => 'Undef' ); + has vDefined => ( is => 'rw', isa => 'Defined' ); + has vInt => ( is => 'rw', isa => 'Int' ); + has vNumber => ( is => 'rw', isa => 'Number' ); + has vStr => ( is => 'rw', isa => 'Str' ); + has vString => ( is => 'rw', isa => 'String' ); + + has v_lazy_Undef => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Undef' ); + has v_lazy_Defined => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Defined' ); + has v_lazy_Int => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Int' ); + has v_lazy_Number => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Number' ); + has v_lazy_Str => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Str' ); + has v_lazy_String => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'String' ); +} + +# EXPORT TYPE CONSTRAINTS +# +Mouse::Util::TypeConstraints->export_type_constraints_as_functions; + +ok( Undef(undef), '... undef is a Undef'); +ok(!Defined(undef), '... undef is NOT a Defined'); +ok(!Int(undef), '... undef is NOT a Int'); +ok(!Number(undef), '... undef is NOT a Number'); +ok(!Str(undef), '... undef is NOT a Str'); +ok(!String(undef), '... undef is NOT a String'); + +ok(!Undef(5), '... 5 is a NOT a Undef'); +ok(Defined(5), '... 5 is a Defined'); +ok(Int(5), '... 5 is a Int'); +ok(Number(5), '... 5 is a Number'); +ok(Str(5), '... 5 is a Str'); +ok(!String(5), '... 5 is NOT a String'); + +ok(!Undef(0.5), '... 0.5 is a NOT a Undef'); +ok(Defined(0.5), '... 0.5 is a Defined'); +ok(!Int(0.5), '... 0.5 is NOT a Int'); +ok(Number(0.5), '... 0.5 is a Number'); +ok(Str(0.5), '... 0.5 is a Str'); +ok(!String(0.5), '... 0.5 is NOT a String'); + +ok(!Undef('Foo'), '... "Foo" is NOT a Undef'); +ok(Defined('Foo'), '... "Foo" is a Defined'); +ok(!Int('Foo'), '... "Foo" is NOT a Int'); +ok(!Number('Foo'), '... "Foo" is NOT a Number'); +ok(Str('Foo'), '... "Foo" is a Str'); +ok(String('Foo'), '... "Foo" is a String'); + + +my $foo = Foo->new; + +lives_ok { $foo->vUndef(undef) } '... undef is a Foo->Undef'; +dies_ok { $foo->vDefined(undef) } '... undef is NOT a Foo->Defined'; +dies_ok { $foo->vInt(undef) } '... undef is NOT a Foo->Int'; +dies_ok { $foo->vNumber(undef) } '... undef is NOT a Foo->Number'; +dies_ok { $foo->vStr(undef) } '... undef is NOT a Foo->Str'; +dies_ok { $foo->vString(undef) } '... undef is NOT a Foo->String'; + +dies_ok { $foo->vUndef(5) } '... 5 is NOT a Foo->Undef'; +lives_ok { $foo->vDefined(5) } '... 5 is a Foo->Defined'; +lives_ok { $foo->vInt(5) } '... 5 is a Foo->Int'; +lives_ok { $foo->vNumber(5) } '... 5 is a Foo->Number'; +lives_ok { $foo->vStr(5) } '... 5 is a Foo->Str'; +dies_ok { $foo->vString(5) } '... 5 is NOT a Foo->String'; + +dies_ok { $foo->vUndef(0.5) } '... 0.5 is NOT a Foo->Undef'; +lives_ok { $foo->vDefined(0.5) } '... 0.5 is a Foo->Defined'; +dies_ok { $foo->vInt(0.5) } '... 0.5 is NOT a Foo->Int'; +lives_ok { $foo->vNumber(0.5) } '... 0.5 is a Foo->Number'; +lives_ok { $foo->vStr(0.5) } '... 0.5 is a Foo->Str'; +dies_ok { $foo->vString(0.5) } '... 0.5 is NOT a Foo->String'; + +dies_ok { $foo->vUndef('Foo') } '... "Foo" is NOT a Foo->Undef'; +lives_ok { $foo->vDefined('Foo') } '... "Foo" is a Foo->Defined'; +dies_ok { $foo->vInt('Foo') } '... "Foo" is NOT a Foo->Int'; +dies_ok { $foo->vNumber('Foo') } '... "Foo" is NOT a Foo->Number'; +lives_ok { $foo->vStr('Foo') } '... "Foo" is a Foo->Str'; +lives_ok { $foo->vString('Foo') } '... "Foo" is a Foo->String'; + +# the lazy tests + +lives_ok { $foo->v_lazy_Undef() } '... undef is a Foo->Undef'; +dies_ok { $foo->v_lazy_Defined() } '... undef is NOT a Foo->Defined'; +dies_ok { $foo->v_lazy_Int() } '... undef is NOT a Foo->Int'; +dies_ok { $foo->v_lazy_Number() } '... undef is NOT a Foo->Number'; +dies_ok { $foo->v_lazy_Str() } '... undef is NOT a Foo->Str'; +dies_ok { $foo->v_lazy_String() } '... undef is NOT a Foo->String'; + + + + diff --git a/t/040_type_constraints/failing/024_role_type_constraint.t b/t/040_type_constraints/failing/024_role_type_constraint.t new file mode 100644 index 0000000..df04adc --- /dev/null +++ b/t/040_type_constraints/failing/024_role_type_constraint.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 18; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +{ + package Gorch; + use Mouse::Role; + + package Bar; + use Mouse::Role; + + package Foo; + use Mouse::Role; + + with qw(Bar Gorch); + + package FooC; + use Mouse; + with qw(Foo); + + package BarC; + use Mouse; + with qw(Bar); + +} + +lives_ok { role_type('Boop', message { "${_} is not a Boop" }) } + 'role_type keywork works with message'; + +my $type = find_type_constraint("Foo"); + +is( $type->role, "Foo", "role attribute" ); + +ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); + +ok( $type->is_subtype_of("Bar"), "subtype of bar" ); + +ok( $type->is_subtype_of("Object"), "subtype of Object" ); + +ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of unknown type name" ); +ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of unknown type name" ); + +ok( find_type_constraint("Bar")->check(FooC->new), "Foo passes Bar" ); +ok( find_type_constraint("Bar")->check(BarC->new), "Bar passes Bar" ); +ok( !find_type_constraint("Gorch")->check(BarC->new), "but Bar doesn't pass Gorch"); + +my $boop = find_type_constraint("Boop"); +ok( $boop->has_message, 'Boop has a message'); +my $error = $boop->get_message(FooC->new); +like( $error, qr/is not a Boop/, 'boop gives correct error message'); + + +ok( $type->equals($type), "equals self" ); +ok( $type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" ); +ok( $type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" ); +ok( !$type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" ); +ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" ); + diff --git a/t/040_type_constraints/failing/025_type_coersion_on_lazy_attributes.t b/t/040_type_constraints/failing/025_type_coersion_on_lazy_attributes.t new file mode 100644 index 0000000..745a4ce --- /dev/null +++ b/t/040_type_constraints/failing/025_type_coersion_on_lazy_attributes.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +{ + package SomeClass; + use Mouse; + use Mouse::Util::TypeConstraints; + + subtype 'DigitSix' => as 'Num' + => where { /^6$/ }; + subtype 'TextSix' => as 'Str' + => where { /Six/i }; + coerce 'TextSix' + => from 'DigitSix' + => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' }; + + has foo => ( + is => 'ro', + isa => 'TextSix', + coerce => 1, + default => 6, + lazy => 1 + ); +} + +my $attr = SomeClass->meta->get_attribute('foo'); +is($attr->get_value(SomeClass->new()), 'Six'); +is(SomeClass->new()->foo, 'Six'); + diff --git a/t/040_type_constraints/failing/026_normalize_type_name.t b/t/040_type_constraints/failing/026_normalize_type_name.t new file mode 100644 index 0000000..e2bc02d --- /dev/null +++ b/t/040_type_constraints/failing/026_normalize_type_name.t @@ -0,0 +1,151 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 37; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +## First, we check that the new regex parsing works + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Str ]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str ]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ Str ]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ Str ]') + ], + [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str ]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int] ]') + ], + [ "ArrayRef", "HashRef[Int]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int] ]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ HashRef[Int ] ]') + ], + [ "ArrayRef", "HashRef[Int ]" ] => + 'Correctly parsed ArrayRef[ HashRef[Int ] ]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[Int|Str]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[Int|Str]') + ], + [ "ArrayRef", "Int|Str" ] => 'Correctly parsed ArrayRef[Int|Str]'; + +ok Mouse::Util::TypeConstraints::_detect_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') => 'detected correctly'; + +is_deeply + [ + Mouse::Util::TypeConstraints::_parse_parameterized_type_constraint( + 'ArrayRef[ArrayRef[Int]|Str]') + ], + [ "ArrayRef", "ArrayRef[Int]|Str" ] => + 'Correctly parsed ArrayRef[ArrayRef[Int]|Str]'; + +## creating names via subtype + +ok my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry => + 'Got registry object'; + +ok my $subtype_a1 + = subtype( 'subtype_a1' => as 'HashRef[Int]' ), => 'created subtype_a1'; + +ok my $subtype_a2 + = subtype( 'subtype_a2' => as 'HashRef[ Int]' ), => 'created subtype_a2'; + +ok my $subtype_a3 + = subtype( 'subtype_a2' => as 'HashRef[Int ]' ), => 'created subtype_a2'; + +ok my $subtype_a4 = subtype( 'subtype_a2' => as 'HashRef[ Int ]' ), => + 'created subtype_a2'; + +is $subtype_a1->parent->name, $subtype_a2->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a3->parent->name => 'names match'; + +is $subtype_a1->parent->name, $subtype_a4->parent->name => 'names match'; + +ok my $subtype_b1 = subtype( 'subtype_b1' => as 'HashRef[Int|Str]' ), => + 'created subtype_b1'; + +ok my $subtype_b2 = subtype( 'subtype_b2' => as 'HashRef[Int | Str]' ), => + 'created subtype_b2'; + +ok my $subtype_b3 = subtype( 'subtype_b3' => as 'HashRef[Str|Int]' ), => + 'created subtype_b3'; + +is $subtype_b1->parent->name, $subtype_b2->parent->name => 'names match'; + +is $subtype_b1->parent->name, $subtype_b3->parent->name => 'names match'; + +is $subtype_b2->parent->name, $subtype_b3->parent->name => 'names match'; + +## testing via add_constraint + +ok my $union1 = Mouse::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union1'; + +ok my $union2 = Mouse::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[ Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union2'; + +ok my $union3 = Mouse::Util::TypeConstraints::create_type_constraint_union( + 'ArrayRef[Int |Str ] | ArrayRef[Int | HashRef ]') => 'Created Union3'; + +is $union1->name, $union2->name, 'names match'; + +is $union1->name, $union3->name, 'names match'; + +is $union2->name, $union3->name, 'names match'; diff --git a/t/040_type_constraints/failing/027_parameterize_from.t b/t/040_type_constraints/failing/027_parameterize_from.t new file mode 100644 index 0000000..7ff3d0a --- /dev/null +++ b/t/040_type_constraints/failing/027_parameterize_from.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 12; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +# testing the parameterize method + +{ + my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; + + my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; + + my $int = Mouse::Util::TypeConstraints::find_type_constraint('Int'); + + my $from_parameterizable = $parameterizable->parameterize($int); + + isa_ok $parameterizable, + 'Mouse::Meta::TypeConstraint::Parameterizable', => + 'Got expected type instance'; + + package Test::Mouse::Meta::TypeConstraint::Parameterizable; + use Mouse; + + has parameterizable => ( is => 'rw', isa => $parameterizable ); + has parameterized => ( is => 'rw', isa => $parameterized ); + has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); +} + +# Create and check a dummy object + +ok my $params = Test::Mouse::Meta::TypeConstraint::Parameterizable->new() => + 'Create Dummy object for testing'; + +isa_ok $params, 'Test::Mouse::Meta::TypeConstraint::Parameterizable' => + 'isa correct type'; + +# test parameterizable + +lives_ok sub { + $params->parameterizable( { a => 'Hello', b => 'World' } ); +} => 'No problem setting parameterizable'; + +is_deeply $params->parameterizable, + { a => 'Hello', b => 'World' } => 'Got expected values'; + +# test parameterized + +lives_ok sub { + $params->parameterized( { a => 1, b => 2 } ); +} => 'No problem setting parameterized'; + +is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values'; + +throws_ok sub { + $params->parameterized( { a => 'Hello', b => 'World' } ); + }, qr/Attribute \(parameterized\) does not pass the type constraint/ => + 'parameterized throws expected error'; + +# test from_parameterizable + +lives_ok sub { + $params->from_parameterizable( { a => 1, b => 2 } ); +} => 'No problem setting from_parameterizable'; + +is_deeply $params->from_parameterizable, + { a => 1, b => 2 } => 'Got expected values'; + +throws_ok sub { + $params->from_parameterizable( { a => 'Hello', b => 'World' } ); + }, + qr/Attribute \(from_parameterizable\) does not pass the type constraint/ + => 'from_parameterizable throws expected error'; diff --git a/t/040_type_constraints/failing/029_define_type_twice_throws.t b/t/040_type_constraints/failing/029_define_type_twice_throws.t new file mode 100644 index 0000000..67bc3ae --- /dev/null +++ b/t/040_type_constraints/failing/029_define_type_twice_throws.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +{ + package Some::Class; + use Mouse::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +} + +throws_ok { + package Some::Other::Class; + use Mouse::Util::TypeConstraints; + + subtype 'MySubType' => as 'Int' => where { 1 }; +} qr/cannot be created again/, 'Trying to create same type twice throws'; + diff --git a/t/040_type_constraints/failing/030_class_subtypes.t b/t/040_type_constraints/failing/030_class_subtypes.t new file mode 100644 index 0000000..6927c3f --- /dev/null +++ b/t/040_type_constraints/failing/030_class_subtypes.t @@ -0,0 +1,141 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 26; +use Test::Exception; + +use Mouse::Util::TypeConstraints; +use Mouse::Meta::TypeConstraint; + + +## Create a subclass with a custom method + +{ + package Test::Mouse::Meta::TypeConstraint::AnySubType; + use Mouse; + extends 'Mouse::Meta::TypeConstraint'; + + sub my_custom_method { + return 1; + } +} + +my $Int = find_type_constraint('Int'); +ok $Int, 'Got a good type contstraint'; + +my $parent = Test::Mouse::Meta::TypeConstraint::AnySubType->new({ + name => "Test::Mouse::Meta::TypeConstraint::AnySubType" , + parent => $Int, +}); + +ok $parent, 'Created type constraint'; +ok $parent->check(1), 'Correctly passed'; +ok ! $parent->check('a'), 'correctly failed'; +ok $parent->my_custom_method, 'found the custom method'; + +my $subtype1 = subtype 'another_subtype' => as $parent; + +ok $subtype1, 'Created type constraint'; +ok $subtype1->check(1), 'Correctly passed'; +ok ! $subtype1->check('a'), 'correctly failed'; +ok $subtype1->my_custom_method, 'found the custom method'; + + +my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; + +ok $subtype2, 'Created type constraint'; +ok $subtype2->check(1), 'Correctly passed'; +ok ! $subtype2->check('a'), 'correctly failed'; +ok ! $subtype2->check(100), 'correctly failed'; + +ok $subtype2->my_custom_method, 'found the custom method'; + + +{ + package Foo; + + use Mouse; +} + +{ + package Bar; + + use Mouse; + + extends 'Foo'; +} + +{ + package Baz; + + use Mouse; +} + +my $foo = class_type 'Foo'; +my $isa_foo = subtype 'IsaFoo' => as $foo; + +ok $isa_foo, 'Created subtype of Foo type'; +ok $isa_foo->check( Foo->new ), 'Foo passes check'; +ok $isa_foo->check( Bar->new ), 'Bar passes check'; +ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check'; +like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' failed with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message'; + +# Maybe in the future this *should* inherit? +like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' failed with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message"; + + +# Implicit types +{ + package Quux; + + use Mouse; + + has age => ( + isa => 'Positive', + is => 'bare', + ); +} + +throws_ok { + Quux->new(age => 3) +} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/; + +lives_ok { + Quux->new(age => (bless {}, 'Positive')); +}; + +eval " + package Positive; + use Mouse; +"; + +throws_ok { + Quux->new(age => 3) +} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/; + +lives_ok { + Quux->new(age => Positive->new) +}; + +class_type 'Negative' => message { "$_ is not a Negative Nancy" }; + +{ + package Quux::Ier; + + use Mouse; + + has age => ( + isa => 'Negative', + is => 'bare', + ); +} + +throws_ok { + Quux::Ier->new(age => 3) +} qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy /; + +lives_ok { + Quux::Ier->new(age => (bless {}, 'Negative')) +}; diff --git a/t/040_type_constraints/failing/031_subtype_auto_vivify_parent.t b/t/040_type_constraints/failing/031_subtype_auto_vivify_parent.t new file mode 100644 index 0000000..e245ab8 --- /dev/null +++ b/t/040_type_constraints/failing/031_subtype_auto_vivify_parent.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +use Mouse::Util::TypeConstraints; + + +{ + package Foo; + + sub new { + my $class = shift; + + return bless {@_}, $class; + } +} + +subtype 'FooWithSize' + => as 'Foo' + => where { $_[0]->{size} }; + + +my $type = find_type_constraint('FooWithSize'); +ok( $type, 'made a FooWithSize constraint' ); +ok( $type->parent, 'type has a parent type' ); +is( $type->parent->name, 'Foo', 'parent type is Foo' ); +isa_ok( $type->parent, 'Mouse::Meta::TypeConstraint::Class', + 'parent type constraint is a class type' ); diff --git a/t/040_type_constraints/failing/032_throw_error.t b/t/040_type_constraints/failing/032_throw_error.t new file mode 100644 index 0000000..d9c992b --- /dev/null +++ b/t/040_type_constraints/failing/032_throw_error.t @@ -0,0 +1,12 @@ +use strict; +use warnings; + +use Test::More tests => 1; + +use Mouse::Util::TypeConstraints; + + +eval { Mouse::Util::TypeConstraints::create_type_constraint_union() }; + +like( $@, qr/\QYou must pass in at least 2 type names to make a union/, + 'can throw a proper error without Mouse being loaded by the caller' ); diff --git a/t/040_type_constraints/failing/033_type_names.t b/t/040_type_constraints/failing/033_type_names.t new file mode 100644 index 0000000..cdfee29 --- /dev/null +++ b/t/040_type_constraints/failing/033_type_names.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More tests => 6; +use Test::Exception; + +use Mouse::Meta::TypeConstraint; +use Mouse::Util::TypeConstraints; + + +TODO: +{ + local $TODO = 'type names are not validated in the TC metaclass'; + + throws_ok { Mouse::Meta::TypeConstraint->new( name => 'Foo-Bar' ) } + qr/contains invalid characters/, + 'Type names cannot contain a dash'; +} + +lives_ok { Mouse::Meta::TypeConstraint->new( name => 'Foo.Bar::Baz' ) } +'Type names can contain periods and colons'; + +throws_ok { subtype 'Foo-Baz' => as 'Item' } +qr/contains invalid characters/, + 'Type names cannot contain a dash (via subtype sugar)'; + +lives_ok { subtype 'Foo.Bar::Baz' => as 'Item' } +'Type names can contain periods and colons (via subtype sugar)'; + +is( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[In-valid]'), + undef, + 'find_or_parse_type_constraint returns undef on an invalid name' ); + +is( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Va.lid]'), + 'ArrayRef[Va.lid]', + 'find_or_parse_type_constraint returns name for valid name' ); diff --git a/t/040_type_constraints/failing/034_duck_types.t b/t/040_type_constraints/failing/034_duck_types.t new file mode 100644 index 0000000..e5b467b --- /dev/null +++ b/t/040_type_constraints/failing/034_duck_types.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Exception; + +{ + + package Duck; + use Mouse; + + sub quack { } + +} + +{ + + package Swan; + use Mouse; + + sub honk { } + +} + +{ + + package RubberDuck; + use Mouse; + + sub quack { } + +} + +{ + + package DucktypeTest; + use Mouse; + use Mouse::Util::TypeConstraints; + + duck_type 'DuckType' => qw(quack); + duck_type 'SwanType' => [qw(honk)]; + + has duck => ( + isa => 'DuckType', + is => 'ro', + lazy_build => 1, + ); + + sub _build_duck { Duck->new } + + has swan => ( + isa => duck_type( [qw(honk)] ), + is => 'ro', + ); + + has other_swan => ( + isa => 'SwanType', + is => 'ro', + ); + +} + +# try giving it a duck +lives_ok { DucktypeTest->new( duck => Duck->new ) } 'the Duck lives okay'; + +# try giving it a swan which is like a duck, but not close enough +throws_ok { DucktypeTest->new( duck => Swan->new ) } +qr/Swan is missing methods 'quack'/, + "the Swan doesn't quack"; + +# try giving it a rubber RubberDuckey +lives_ok { DucktypeTest->new( swan => Swan->new ) } 'but a Swan can honk'; + +# try giving it a rubber RubberDuckey +lives_ok { DucktypeTest->new( duck => RubberDuck->new ) } +'the RubberDuck lives okay'; + +# try with the other constraint form +lives_ok { DucktypeTest->new( other_swan => Swan->new ) } 'but a Swan can honk'; diff --git a/t/040_type_constraints/failing/035_duck_type_handles.t b/t/040_type_constraints/failing/035_duck_type_handles.t new file mode 100644 index 0000000..40fe414 --- /dev/null +++ b/t/040_type_constraints/failing/035_duck_type_handles.t @@ -0,0 +1,46 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +my @phonograph; +{ + package Duck; + use Mouse; + + sub walk { + push @phonograph, 'footsteps', + } + + sub quack { + push @phonograph, 'quack'; + } + + package Swan; + use Mouse; + + sub honk { + push @phonograph, 'honk'; + } + + package DucktypeTest; + use Mouse; + use Mouse::Util::TypeConstraints; + + my $ducktype = duck_type 'DuckType' => qw(walk quack); + + has duck => ( + isa => $ducktype, + handles => $ducktype, + ); +} + +my $t = DucktypeTest->new(duck => Duck->new); +$t->quack; +is_deeply([splice @phonograph], ['quack']); + +$t->walk; +is_deeply([splice @phonograph], ['footsteps']); + diff --git a/t/040_type_constraints/failing/036_match_type_operator.t b/t/040_type_constraints/failing/036_match_type_operator.t new file mode 100644 index 0000000..524c42d --- /dev/null +++ b/t/040_type_constraints/failing/036_match_type_operator.t @@ -0,0 +1,228 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 25; +use Test::Exception; + +use Mouse::Util::TypeConstraints; + +# some simple type dispatching ... + +subtype 'Null' + => as 'ArrayRef' + => where { scalar @{$_} == 0 }; + +sub head { + match_on_type @_ => + Null => sub { die "Cannot get the head of Null" }, + ArrayRef => sub { $_->[0] }; +} + +sub tail { + match_on_type @_ => + Null => sub { die "Cannot get the tail of Null" }, + ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; +} + +sub len { + match_on_type @_ => + Null => sub { 0 }, + ArrayRef => sub { len( tail( $_ ) ) + 1 }; +} + +sub rev { + match_on_type @_ => + Null => sub { [] }, + ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; +} + +is( len( [] ), 0, '... got the right length'); +is( len( [ 1 ] ), 1, '... got the right length'); +is( len( [ 1 .. 5 ] ), 5, '... got the right length'); +is( len( [ 1 .. 50 ] ), 50, '... got the right length'); + +is_deeply( + rev( [ 1 .. 5 ] ), + [ reverse 1 .. 5 ], + '... got the right reversed value' +); + +# break down a Maybe Type ... + +sub break_it_down { + match_on_type shift, + 'Maybe[Str]' => sub { + match_on_type $_ => + 'Undef' => sub { 'undef' }, + 'Str' => sub { $_ } + }, + sub { 'default' } +} + + +is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); +is( break_it_down( [] ), 'default', '... got the right value'); +is( break_it_down( undef ), 'undef', '... got the right value'); +is( break_it_down(), 'undef', '... got the right value'); + +# checking against enum types + +enum RGB => qw[ red green blue ]; +enum CMYK => qw[ cyan magenta yellow black ]; + +sub is_acceptable_color { + match_on_type shift, + 'RGB' => sub { 'RGB' }, + 'CMYK' => sub { 'CMYK' }, + sub { die "bad color $_" }; +} + +is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); +is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); +is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); + +dies_ok { + is_acceptable_color( 'orange' ) +} '... got the exception'; + +## using it in an OO context + +{ + package LinkedList; + use Mouse; + use Mouse::Util::TypeConstraints; + + has 'next' => ( + is => 'ro', + isa => __PACKAGE__, + lazy => 1, + default => sub { __PACKAGE__->new }, + predicate => 'has_next' + ); + + sub pprint { + my $list = shift; + match_on_type $list => + subtype( + as 'LinkedList', + where { ! $_->has_next } + ) => sub { '[]' }, + 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; + } +} + +my $l = LinkedList->new; +is($l->pprint, '[]', '... got the right pprint'); +$l->next; +is($l->pprint, '[[]]', '... got the right pprint'); +$l->next->next; +is($l->pprint, '[[[]]]', '... got the right pprint'); +$l->next->next->next; +is($l->pprint, '[[[[]]]]', '... got the right pprint'); + +# basic data dumper + +{ + package Foo; + use Mouse; + + sub to_string { 'Foo()' } +} + +use B; + +sub ppprint { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + $_ . ' => ' . ppprint( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' }, + CodeRef => sub { 'sub { ... }' }, + RegexpRef => sub { 'qr/' . $_ . '/' }, + GlobRef => sub { '*' . B::svref_2object($_)->NAME }, + Object => sub { $_->can('to_string') ? $_->to_string : $_ }, + ScalarRef => sub { '\\' . ppprint( ${$_} ) }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'undef' }, + => sub { die "I don't know what $_ is" }; +} + +is( + ppprint( + { + one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], + two => undef, + three => sub { "OH HAI" }, + four => qr/.*?/, + five => \*ppprint, + six => Foo->new, + } + ), + '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }', + '... got the right pretty printed values' +); + +# simple JSON serializer + +sub to_json { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'null' }, + => sub { die "$_ is not acceptable json type" }; +} + +is( + to_json( { one => 1, two => 2 } ), + '{ "one" : 1, "two" : 2 }', + '... got our valid JSON' +); + +is( + to_json( { + one => [ 1, 2, 3, 4 ], + two => undef, + three => "Hello World" + } ), + '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }', + '... got our valid JSON' +); + + +# some error cases + +sub not_enough_matches { + my $x = shift; + match_on_type $x => + Undef => sub { 'hello undef world' }, + CodeRef => sub { $_->('Hello code ref world') }; +} + +throws_ok { + not_enough_matches( [] ) +} qr/No cases matched for /, '... not enough matches'; + + + +