From: gfx Date: Sat, 24 Oct 2009 04:00:55 +0000 (+0900) Subject: Merge branch 'master' into blead X-Git-Tag: 0.40_01~42 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=2a7e621027a0980e8bcccd24ac3b3fe33b516a72;hp=45bbec05d8a9057428aa9399662297300d79b791 Merge branch 'master' into blead --- diff --git a/Changes b/Changes index 67a117e..cde760f 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,11 @@ Revision history for Mouse +0.40 Mon Oct 19 18:30:32 2009 + * Mouse::Meta::TypeConstraint + - Fix a subtyping issue (Thanks miyagawa san) + * Mouse/Mouse::Role + - Now export their sugars to the "main" package + 0.39 Tue Oct 13 16:42:31 2009 * Fix RT #50421 (Thanks Michael G Schwern) * Fix RT #50422 (Thanks Michael G Schwern) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 8d65183..746188b 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -37,6 +37,7 @@ # Moose specific tests xt/compatibility +xt/external t/.*/failing ^TODO$ diff --git a/Makefile.PL b/Makefile.PL index 38c8a06..6800f72 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -55,7 +55,7 @@ sub create_moose_compatibility_test { # some test does not pass... currently skip it. my %SKIP_TEST = ( '016-trigger.t' => "trigger's argument is incompatble :(", - '010-isa-or.t' => "Mouse has a [BUG]", + '810-isa-or.t' => "Mouse has a [BUG]", '052-undefined-type-in-union.t' => "Mouse accepts undefined type as a member of union types", '054-anon-leak.t' => 'Moose has memory leaks', diff --git a/lib/Mouse.pm b/lib/Mouse.pm index f841265..a0ea7c3 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -3,7 +3,7 @@ use 5.006_002; use Mouse::Exporter; # enables strict and warnings -our $VERSION = '0.39'; +our $VERSION = '0.40'; use Carp qw(confess); use Scalar::Util qw(blessed); @@ -160,7 +160,7 @@ Mouse - Moose minus the antlers =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SYNOPSIS diff --git a/lib/Mouse/Exporter.pm b/lib/Mouse/Exporter.pm index 2b25018..82b10f4 100644 --- a/lib/Mouse/Exporter.pm +++ b/lib/Mouse/Exporter.pm @@ -168,11 +168,6 @@ sub do_import { $^H |= _strict_bits; # strict->import; ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import; - if($into eq 'main' && !$spec->{_export_to_main}){ - warn qq{$package does not export its sugar to the 'main' package.\n}; - return; - } - if($spec->{INIT_META}){ my $meta; foreach my $init_meta(@{$spec->{INIT_META}}){ @@ -265,7 +260,7 @@ Mouse::Exporter - make an import() and unimport() just like Mouse.pm =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SYNOPSIS diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 2d75d0e..dff0b1e 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -464,7 +464,7 @@ Mouse::Meta::Attribute - The Mouse attribute metaclass =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 METHODS diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 7b40497..50f21b5 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -44,6 +44,13 @@ sub is_anon_class{ sub roles { $_[0]->{roles} } +sub calculate_all_roles { + my $self = shift; + my %seen; + return grep { !$seen{ $_->name }++ } + map { $_->calculate_all_roles } @{ $self->roles }; +} + sub superclasses { my $self = shift; @@ -474,7 +481,7 @@ Mouse::Meta::Class - The Mouse class metaclass =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 METHODS diff --git a/lib/Mouse/Meta/Method.pm b/lib/Mouse/Meta/Method.pm index 1959f9d..458dbbb 100755 --- a/lib/Mouse/Meta/Method.pm +++ b/lib/Mouse/Meta/Method.pm @@ -31,7 +31,7 @@ Mouse::Meta::Method - A Mouse Method metaclass =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm index 581c4ce..ad7a8f0 100755 --- a/lib/Mouse/Meta/Method/Accessor.pm +++ b/lib/Mouse/Meta/Method/Accessor.pm @@ -194,7 +194,7 @@ Mouse::Meta::Method::Accessor - A Mouse method generator for accessors =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index 7d4ccc9..e931885 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -191,7 +191,7 @@ Mouse::Meta::Method::Constructor - A Mouse method generator for constructors =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Method/Destructor.pm b/lib/Mouse/Meta/Method/Destructor.pm index 7c12dc8..a596c9b 100644 --- a/lib/Mouse/Meta/Method/Destructor.pm +++ b/lib/Mouse/Meta/Method/Destructor.pm @@ -55,7 +55,7 @@ Mouse::Meta::Method::Accessor - A Mouse method generator for destructors =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index 92619f8..227313e 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -326,7 +326,7 @@ Mouse::Meta::Module - The base class for Mouse::Meta::Class and Mouse::Meta::Rol =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 9c56aab..4c53da3 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -35,6 +35,13 @@ sub is_anon_role{ sub get_roles { $_[0]->{roles} } +sub calculate_all_roles { + my $self = shift; + my %seen; + return grep { !$seen{ $_->name }++ } + ($self, map { $_->calculate_all_roles } @{ $self->get_roles }); +} + sub get_required_method_list{ return @{ $_[0]->{required_methods} }; } @@ -316,7 +323,7 @@ Mouse::Meta::Role - The Mouse Role metaclass =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Role/Composite.pm b/lib/Mouse/Meta/Role/Composite.pm index 0dfaad4..3dd72a4 100644 --- a/lib/Mouse/Meta/Role/Composite.pm +++ b/lib/Mouse/Meta/Role/Composite.pm @@ -120,7 +120,7 @@ Mouse::Meta::Role::Composite - An object to represent the set of roles =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/Role/Method.pm b/lib/Mouse/Meta/Role/Method.pm index 3012493..e86f9a1 100755 --- a/lib/Mouse/Meta/Role/Method.pm +++ b/lib/Mouse/Meta/Role/Method.pm @@ -13,7 +13,7 @@ Mouse::Meta::Role::Method - A Mouse Method metaclass for Roles =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SEE ALSO diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm index 9dd67db..d106313 100644 --- a/lib/Mouse/Meta/TypeConstraint.pm +++ b/lib/Mouse/Meta/TypeConstraint.pm @@ -101,11 +101,11 @@ sub compile_type_constraint{ my @checks; for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){ if($parent->{hand_optimized_type_constraint}){ - push @checks, $parent->{hand_optimized_type_constraint}; + unshift @checks, $parent->{hand_optimized_type_constraint}; last; # a hand optimized constraint must include all the parents } elsif($parent->{constraint}){ - push @checks, $parent->{constraint}; + unshift @checks, $parent->{constraint}; } } @@ -249,7 +249,7 @@ Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 DESCRIPTION diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index 6e43b02..72e929b 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -95,7 +95,7 @@ Mouse::Object - The base object for Mouse classes =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 METHODS diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm index e10c34d..fc80d40 100644 --- a/lib/Mouse/Role.pm +++ b/lib/Mouse/Role.pm @@ -1,7 +1,7 @@ package Mouse::Role; use Mouse::Exporter; # enables strict and warnings -our $VERSION = '0.39'; +our $VERSION = '0.40'; use Carp qw(confess); use Scalar::Util qw(blessed); @@ -143,7 +143,7 @@ Mouse::Role - The Mouse Role =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SYNOPSIS diff --git a/lib/Mouse/Spec.pm b/lib/Mouse/Spec.pm index 7f791a4..249067e 100644 --- a/lib/Mouse/Spec.pm +++ b/lib/Mouse/Spec.pm @@ -2,7 +2,7 @@ package Mouse::Spec; use strict; use warnings; -our $VERSION = '0.39'; +our $VERSION = '0.40'; our $MouseVersion = $VERSION; our $MooseVersion = '0.90'; @@ -19,7 +19,7 @@ Mouse::Spec - To what extent Mouse is compatible with Moose =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 SYNOPSIS diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index 32f8f7b..9a34e0c 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -34,7 +34,6 @@ Mouse::Exporter->setup_import_methods( # The ':meta' group is 'use metaclass' for Mouse meta => [qw(does meta dump _MOUSE_VERBOSE)], }, - _export_to_main => 1, ); # aliases as public APIs @@ -354,7 +353,7 @@ Mouse::Util - Features, with or without their dependencies =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head1 IMPLEMENTATIONS FOR diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 56d4734..96a56dc 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -14,8 +14,6 @@ Mouse::Exporter->setup_import_methods( type subtype coerce class_type role_type enum find_type_constraint )], - - _export_to_main => 1, ); my %TYPE; @@ -425,7 +423,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40 =head2 SYNOPSIS diff --git a/t/001_mouse/038-main.t b/t/001_mouse/038-main.t deleted file mode 100644 index 6f68a4f..0000000 --- a/t/001_mouse/038-main.t +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -BEGIN { - eval "use Test::Output;"; - plan skip_all => "Test::Output is required for this test" if $@; - plan tests => 2; -} - -stderr_is( - sub { package main; eval 'use Mouse' }, - "Mouse does not export its sugar to the 'main' package.\n", - 'Mouse warns when loaded from the main package', -); - -stderr_is( - sub { package main; eval 'use Mouse::Role' }, - "Mouse::Role does not export its sugar to the 'main' package.\n", - 'Mouse::Role warns when loaded from the main package', -); - diff --git a/t/001_mouse/039-subtype.t b/t/001_mouse/039-subtype.t index 755c405..50b7bf9 100644 --- a/t/001_mouse/039-subtype.t +++ b/t/001_mouse/039-subtype.t @@ -1,7 +1,7 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 7; +use Test::More tests => 11; use Test::Exception; use Mouse::Util::TypeConstraints; @@ -16,10 +16,16 @@ do { => where { length $_ } => message { "The string is empty!" }; + subtype 'MyClass' + => as 'Object' + => where { $_->isa(__PACKAGE__) }; + has name => ( is => 'ro', isa => 'NonemptyStr', ); + + }; ok(My::Class->new(name => 'foo')); @@ -35,3 +41,10 @@ ok $st->check('Foo'); ok!$st->check(undef); ok!$st->check(''); +lives_and{ + my $tc = find_type_constraint('MyClass'); + ok $tc->check(My::Class->new()); + ok!$tc->check('My::Class'); + ok!$tc->check([]); + ok!$tc->check(undef); +}; diff --git a/t/001_mouse/057_subtype_without_where.t b/t/001_mouse/057_subtype_without_where.t new file mode 100644 index 0000000..520037e --- /dev/null +++ b/t/001_mouse/057_subtype_without_where.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl -w +use Test::More tests => 4; +use Test::Exception; + +use Mouse::Util::TypeConstraints; + +{ + package Class; + sub new { + my $class = shift; + return bless { @_ }, $class; + } +} + +subtype 'Class', + as 'Object', + where { $_->isa('Class') }; + +subtype 'C', as 'Class'; # subtyping without "where" + +coerce 'C', + from 'Str', + via { Class->new(content => $_) }, + from 'HashRef', + via { Class->new(content => $_->{content}) }; + +{ + package A; + use Mouse; + + has foo => ( + is => 'ro', + isa => 'C', + coerce => 1, + required => 1, + ); +} + +lives_and{ + my $a = A->new(foo => 'foobar'); + isa_ok $a->foo, 'Class'; + is $a->foo->{content}, 'foobar'; +}; + +lives_and{ + my $a = A->new(foo => { content => 42 }); + isa_ok $a->foo, 'Class'; + is $a->foo->{content}, 42; +}; diff --git a/t/800_shikabased/001-coerce.t b/t/001_mouse/801-coerce.t similarity index 92% rename from t/800_shikabased/001-coerce.t rename to t/001_mouse/801-coerce.t index 5b19a5b..42093c1 100644 --- a/t/800_shikabased/001-coerce.t +++ b/t/001_mouse/801-coerce.t @@ -13,7 +13,7 @@ use Test::More tests => 6; use Mouse; use Mouse::Util::TypeConstraints; - subtype 'HeadersType' => as 'Object' => where { defined $_ && eval { $_->isa('Headers') } }; + subtype 'HeadersType' => as 'Object' => where { $_->isa('Headers') }; coerce 'HeadersType' => from 'ScalarRef' => via { Headers->new(); diff --git a/t/800_shikabased/002-coerce_multi_class.t b/t/001_mouse/802-coerce_multi_class.t similarity index 96% rename from t/800_shikabased/002-coerce_multi_class.t rename to t/001_mouse/802-coerce_multi_class.t index 0e2d903..c899374 100644 --- a/t/800_shikabased/002-coerce_multi_class.t +++ b/t/001_mouse/802-coerce_multi_class.t @@ -18,7 +18,7 @@ use Test::More tests => 13; use Mouse; use Mouse::Util::TypeConstraints; - type 'Headers' => where { defined $_ && eval { $_->isa('Response::Headers') } }; + subtype 'Headers' => as 'Object', where { $_->isa('Response::Headers') }; coerce 'Headers' => from 'HashRef' => via { Response::Headers->new(%{ $_ }); diff --git a/t/800_shikabased/004-immutable-demolish.t b/t/001_mouse/804-immutable-demolish.t similarity index 100% rename from t/800_shikabased/004-immutable-demolish.t rename to t/001_mouse/804-immutable-demolish.t diff --git a/t/800_shikabased/005-class_type.t b/t/001_mouse/805-class_type.t similarity index 100% rename from t/800_shikabased/005-class_type.t rename to t/001_mouse/805-class_type.t diff --git a/t/800_shikabased/006-role_type.t b/t/001_mouse/806-role_type.t similarity index 100% rename from t/800_shikabased/006-role_type.t rename to t/001_mouse/806-role_type.t diff --git a/t/800_shikabased/007-multi-roles.t b/t/001_mouse/807-multi-roles.t similarity index 100% rename from t/800_shikabased/007-multi-roles.t rename to t/001_mouse/807-multi-roles.t diff --git a/t/800_shikabased/008-create_class.t b/t/001_mouse/808-create_class.t similarity index 100% rename from t/800_shikabased/008-create_class.t rename to t/001_mouse/808-create_class.t diff --git a/t/800_shikabased/009-overwrite-builtin-subtype.t b/t/001_mouse/809-overwrite-builtin-subtype.t similarity index 100% rename from t/800_shikabased/009-overwrite-builtin-subtype.t rename to t/001_mouse/809-overwrite-builtin-subtype.t diff --git a/t/800_shikabased/010-isa-or.t b/t/001_mouse/810-isa-or.t similarity index 100% rename from t/800_shikabased/010-isa-or.t rename to t/001_mouse/810-isa-or.t diff --git a/t/800_shikabased/011-util-linear-isa.t b/t/001_mouse/811-util-linear-isa.t similarity index 100% rename from t/800_shikabased/011-util-linear-isa.t rename to t/001_mouse/811-util-linear-isa.t diff --git a/t/800_shikabased/012-role-compatibility.t b/t/001_mouse/812-role-compatibility.t similarity index 100% rename from t/800_shikabased/012-role-compatibility.t rename to t/001_mouse/812-role-compatibility.t diff --git a/t/800_shikabased/013-compatibility-get_method_list.t b/t/001_mouse/813-compatibility-get_method_list.t similarity index 100% rename from t/800_shikabased/013-compatibility-get_method_list.t rename to t/001_mouse/813-compatibility-get_method_list.t diff --git a/t/800_shikabased/014-subtype-as.t b/t/001_mouse/814-subtype-as.t similarity index 100% rename from t/800_shikabased/014-subtype-as.t rename to t/001_mouse/814-subtype-as.t diff --git a/t/010_basics/016_load_into_main.t b/t/010_basics/016_load_into_main.t deleted file mode 100755 index 58737b7..0000000 --- a/t/010_basics/016_load_into_main.t +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - eval "use Test::Output;"; - plan skip_all => "Test::Output is required for this test" if $@; - plan tests => 2; -} - -stderr_like( sub { package main; eval 'use Mouse' }, - qr/\QMouse does not export its sugar to the 'main' package/, - 'Mouse warns when loaded from the main package' ); - -stderr_like( sub { package main; eval 'use Mouse::Role' }, - qr/\QMouse::Role does not export its sugar to the 'main' package/, - 'Mouse::Role warns when loaded from the main package' ); diff --git a/t/040_type_constraints/005_util_type_coercion.t b/t/040_type_constraints/005_util_type_coercion.t new file mode 100644 index 0000000..c5fce12 --- /dev/null +++ b/t/040_type_constraints/005_util_type_coercion.t @@ -0,0 +1,108 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; # tests => 26; +use Test::Exception; + +use lib 't/lib'; +use Test::Mouse; + +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'; + +=pod + +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'); + } +} + +=cut + +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/007_util_more_type_coercion.t b/t/040_type_constraints/007_util_more_type_coercion.t new file mode 100644 index 0000000..1cfa831 --- /dev/null +++ b/t/040_type_constraints/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/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/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/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/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/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..798a448 --- /dev/null +++ b/t/040_type_constraints/failing/012_container_type_coercion.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; +use Test::Exception; + +BEGIN { + use_ok('Mouse::Util::TypeConstraints'); +} + +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/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/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/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'; + + + + diff --git a/xt/external/lib/Foo.pm b/xt/external/lib/Foo.pm new file mode 100644 index 0000000..3fbedeb --- /dev/null +++ b/xt/external/lib/Foo.pm @@ -0,0 +1,30 @@ +package Foo; +use Mouse; + +has foo => ( + is => 'ro', + isa => 'Str', +); + +has bar => ( + is => 'ro', + isa => 'Str', +); + +no Mouse; +__PACKAGE__->meta->make_immutable; +__END__ + +=head1 NAME + +Foo - bar + +=head1 ATTRIBUTES + +=over 4 + +=item foo + +=back + +=cut diff --git a/xt/external/pod-coverage-moose.t b/xt/external/pod-coverage-moose.t new file mode 100644 index 0000000..4818f91 --- /dev/null +++ b/xt/external/pod-coverage-moose.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; +use FindBin; +use File::Spec; +use lib File::Spec->catfile($FindBin::Bin, 'lib'); + +plan skip_all => 'This test requires Pod::Coverage::Moose' unless eval "use Pod::Coverage::Moose; 1"; +plan tests => 1; + +# support Pod::Coverage::Moose +# https://rt.cpan.org/Ticket/Display.html?id=47744 + +{ + local $TODO = 'Not supported'; + my $cov = Pod::Coverage::Moose->new(package => 'Foo'); + is $cov->coverage, 0.5; +}