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)
# Moose specific tests
xt/compatibility
+xt/external
t/.*/failing
^TODO$
# 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',
use Mouse::Exporter; # enables strict and warnings
-our $VERSION = '0.39';
+our $VERSION = '0.40';
use Carp qw(confess);
use Scalar::Util qw(blessed);
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SYNOPSIS
$^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}}){
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SYNOPSIS
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 METHODS
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;
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 METHODS
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
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} };
}
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SEE ALSO
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};
}
}
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 DESCRIPTION
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 METHODS
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);
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SYNOPSIS
use strict;
use warnings;
-our $VERSION = '0.39';
+our $VERSION = '0.40';
our $MouseVersion = $VERSION;
our $MooseVersion = '0.90';
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 SYNOPSIS
# The ':meta' group is 'use metaclass' for Mouse
meta => [qw(does meta dump _MOUSE_VERBOSE)],
},
- _export_to_main => 1,
);
# aliases as public APIs
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head1 IMPLEMENTATIONS FOR
type subtype coerce class_type role_type enum
find_type_constraint
)],
-
- _export_to_main => 1,
);
my %TYPE;
=head1 VERSION
-This document describes Mouse version 0.39
+This document describes Mouse version 0.40
=head2 SYNOPSIS
+++ /dev/null
-#!/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',
-);
-
#!/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;
=> 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'));
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);
+};
--- /dev/null
+#!/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;
+};
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();
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(%{ $_ });
+++ /dev/null
-#!/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' );
--- /dev/null
+#!/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");
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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');
+}
+
--- /dev/null
+#!/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' );
+}
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+#!/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');
+
--- /dev/null
+#!/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"
+ );
+}
--- /dev/null
+#!/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' );
+}
--- /dev/null
+#!/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!');
+
+
--- /dev/null
+#!/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');
+
+
+
--- /dev/null
+#!/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;
+}
--- /dev/null
+#!/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';
+}
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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)');
+
--- /dev/null
+#!/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" );
+
--- /dev/null
+#!/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")';
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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';
+
+
+
+
--- /dev/null
+#!/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" );
+
--- /dev/null
+#!/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';
--- /dev/null
+#!/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';
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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'))
+};
--- /dev/null
+#!/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' );
--- /dev/null
+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' );
--- /dev/null
+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' );
--- /dev/null
+#!/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';
--- /dev/null
+#!/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']);
+
--- /dev/null
+#!/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';
+
+
+
+
--- /dev/null
+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
--- /dev/null
+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;
+}