--- /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 => 297;
+use Test::Exception;
+
+use Scalar::Util ();
+
+BEGIN {
+ use_ok('Mouse::Util::TypeConstraints');
+}
+
+my $SCALAR_REF = \(my $var);
+
+no warnings 'once'; # << I *hates* that warning ...
+my $GLOB = *GLOB_REF;
+my $GLOB_REF = \$GLOB;
+
+my $fh;
+open($fh, '<', $0) || die "Could not open $0 for the test";
+
+my $fh_obj = bless {}, "IO::Handle"; # not really
+
+Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
+
+ok(defined Any(0), '... Any accepts anything');
+ok(defined Any(100), '... Any accepts anything');
+ok(defined Any(''), '... Any accepts anything');
+ok(defined Any('Foo'), '... Any accepts anything');
+ok(defined Any([]), '... Any accepts anything');
+ok(defined Any({}), '... Any accepts anything');
+ok(defined Any(sub {}), '... Any accepts anything');
+ok(defined Any($SCALAR_REF), '... Any accepts anything');
+ok(defined Any($GLOB), '... Any accepts anything');
+ok(defined Any($GLOB_REF), '... Any accepts anything');
+ok(defined Any($fh), '... Any accepts anything');
+ok(defined Any(qr/../), '... Any accepts anything');
+ok(defined Any(bless {}, 'Foo'), '... Any accepts anything');
+ok(defined Any(undef), '... Any accepts anything');
+
+ok(defined Item(0), '... Item is the base type, so accepts anything');
+ok(defined Item(100), '... Item is the base type, so accepts anything');
+ok(defined Item(''), '... Item is the base type, so accepts anything');
+ok(defined Item('Foo'), '... Item is the base type, so accepts anything');
+ok(defined Item([]), '... Item is the base type, so accepts anything');
+ok(defined Item({}), '... Item is the base type, so accepts anything');
+ok(defined Item(sub {}), '... Item is the base type, so accepts anything');
+ok(defined Item($SCALAR_REF), '... Item is the base type, so accepts anything');
+ok(defined Item($GLOB), '... Item is the base type, so accepts anything');
+ok(defined Item($GLOB_REF), '... Item is the base type, so accepts anything');
+ok(defined Item($fh), '... Item is the base type, so accepts anything');
+ok(defined Item(qr/../), '... Item is the base type, so accepts anything');
+ok(defined Item(bless {}, 'Foo'), '... Item is the base type, so accepts anything');
+ok(defined Item(undef), '... Item is the base type, so accepts anything');
+
+ok(defined Defined(0), '... Defined accepts anything which is defined');
+ok(defined Defined(100), '... Defined accepts anything which is defined');
+ok(defined Defined(''), '... Defined accepts anything which is defined');
+ok(defined Defined('Foo'), '... Defined accepts anything which is defined');
+ok(defined Defined([]), '... Defined accepts anything which is defined');
+ok(defined Defined({}), '... Defined accepts anything which is defined');
+ok(defined Defined(sub {}), '... Defined accepts anything which is defined');
+ok(defined Defined($SCALAR_REF), '... Defined accepts anything which is defined');
+ok(defined Defined($GLOB), '... Defined accepts anything which is defined');
+ok(defined Defined($GLOB_REF), '... Defined accepts anything which is defined');
+ok(defined Defined($fh), '... Defined accepts anything which is defined');
+ok(defined Defined(qr/../), '... Defined accepts anything which is defined');
+ok(defined Defined(bless {}, 'Foo'), '... Defined accepts anything which is defined');
+ok(!defined Defined(undef), '... Defined accepts anything which is defined');
+
+ok(!defined Undef(0), '... Undef accepts anything which is not defined');
+ok(!defined Undef(100), '... Undef accepts anything which is not defined');
+ok(!defined Undef(''), '... Undef accepts anything which is not defined');
+ok(!defined Undef('Foo'), '... Undef accepts anything which is not defined');
+ok(!defined Undef([]), '... Undef accepts anything which is not defined');
+ok(!defined Undef({}), '... Undef accepts anything which is not defined');
+ok(!defined Undef(sub {}), '... Undef accepts anything which is not defined');
+ok(!defined Undef($SCALAR_REF), '... Undef accepts anything which is not defined');
+ok(!defined Undef($GLOB), '... Undef accepts anything which is not defined');
+ok(!defined Undef($GLOB_REF), '... Undef accepts anything which is not defined');
+ok(!defined Undef($fh), '... Undef accepts anything which is not defined');
+ok(!defined Undef(qr/../), '... Undef accepts anything which is not defined');
+ok(!defined Undef(bless {}, 'Foo'), '... Undef accepts anything which is not defined');
+ok(defined Undef(undef), '... Undef accepts anything which is not defined');
+
+ok(defined Bool(0), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(defined Bool(1), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool(100), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(defined Bool(''), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool('Foo'), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool([]), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool({}), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool(sub {}), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool($SCALAR_REF), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool($GLOB), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool($GLOB_REF), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool($fh), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool(qr/../), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(!defined Bool(bless {}, 'Foo'), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+ok(defined Bool(undef), '... Bool rejects anything which is not a 1 or 0 or "" or undef');
+
+ok(defined Value(0), '... Value accepts anything which is not a Ref');
+ok(defined Value(100), '... Value accepts anything which is not a Ref');
+ok(defined Value(''), '... Value accepts anything which is not a Ref');
+ok(defined Value('Foo'), '... Value accepts anything which is not a Ref');
+ok(!defined Value([]), '... Value rejects anything which is not a Value');
+ok(!defined Value({}), '... Value rejects anything which is not a Value');
+ok(!defined Value(sub {}), '... Value rejects anything which is not a Value');
+ok(!defined Value($SCALAR_REF), '... Value rejects anything which is not a Value');
+ok(defined Value($GLOB), '... Value accepts anything which is not a Ref');
+ok(!defined Value($GLOB_REF), '... Value rejects anything which is not a Value');
+ok(!defined Value($fh), '... Value rejects anything which is not a Value');
+ok(!defined Value(qr/../), '... Value rejects anything which is not a Value');
+ok(!defined Value(bless {}, 'Foo'), '... Value rejects anything which is not a Value');
+ok(!defined Value(undef), '... Value rejects anything which is not a Value');
+
+ok(!defined Ref(0), '... Ref accepts anything which is not a Value');
+ok(!defined Ref(100), '... Ref accepts anything which is not a Value');
+ok(!defined Ref(''), '... Ref accepts anything which is not a Value');
+ok(!defined Ref('Foo'), '... Ref accepts anything which is not a Value');
+ok(defined Ref([]), '... Ref rejects anything which is not a Ref');
+ok(defined Ref({}), '... Ref rejects anything which is not a Ref');
+ok(defined Ref(sub {}), '... Ref rejects anything which is not a Ref');
+ok(defined Ref($SCALAR_REF), '... Ref rejects anything which is not a Ref');
+ok(!defined Ref($GLOB), '... Ref accepts anything which is not a Value');
+ok(defined Ref($GLOB_REF), '... Ref rejects anything which is not a Ref');
+ok(defined Ref($fh), '... Ref rejects anything which is not a Ref');
+ok(defined Ref(qr/../), '... Ref rejects anything which is not a Ref');
+ok(defined Ref(bless {}, 'Foo'), '... Ref rejects anything which is not a Ref');
+ok(!defined Ref(undef), '... Ref rejects anything which is not a Ref');
+
+ok(defined Int(0), '... Int accepts anything which is an Int');
+ok(defined Int(100), '... Int accepts anything which is an Int');
+ok(!defined Int(0.5), '... Int accepts anything which is not a Int');
+ok(!defined Int(100.01), '... Int accepts anything which is not a Int');
+ok(!defined Int(''), '... Int rejects anything which is not a Int');
+ok(!defined Int('Foo'), '... Int rejects anything which is not a Int');
+ok(!defined Int([]), '... Int rejects anything which is not a Int');
+ok(!defined Int({}), '... Int rejects anything which is not a Int');
+ok(!defined Int(sub {}), '... Int rejects anything which is not a Int');
+ok(!defined Int($SCALAR_REF), '... Int rejects anything which is not a Int');
+ok(!defined Int($GLOB), '... Int rejects anything which is not a Int');
+ok(!defined Int($GLOB_REF), '... Int rejects anything which is not a Int');
+ok(!defined Int($fh), '... Int rejects anything which is not a Int');
+ok(!defined Int(qr/../), '... Int rejects anything which is not a Int');
+ok(!defined Int(bless {}, 'Foo'), '... Int rejects anything which is not a Int');
+ok(!defined Int(undef), '... Int rejects anything which is not a Int');
+
+ok(defined Num(0), '... Num accepts anything which is an Num');
+ok(defined Num(100), '... Num accepts anything which is an Num');
+ok(defined Num(0.5), '... Num accepts anything which is an Num');
+ok(defined Num(100.01), '... Num accepts anything which is an Num');
+ok(!defined Num(''), '... Num rejects anything which is not a Num');
+ok(!defined Num('Foo'), '... Num rejects anything which is not a Num');
+ok(!defined Num([]), '... Num rejects anything which is not a Num');
+ok(!defined Num({}), '... Num rejects anything which is not a Num');
+ok(!defined Num(sub {}), '... Num rejects anything which is not a Num');
+ok(!defined Num($SCALAR_REF), '... Num rejects anything which is not a Num');
+ok(!defined Num($GLOB), '... Num rejects anything which is not a Num');
+ok(!defined Num($GLOB_REF), '... Num rejects anything which is not a Num');
+ok(!defined Num($fh), '... Num rejects anything which is not a Num');
+ok(!defined Num(qr/../), '... Num rejects anything which is not a Num');
+ok(!defined Num(bless {}, 'Foo'), '... Num rejects anything which is not a Num');
+ok(!defined Num(undef), '... Num rejects anything which is not a Num');
+
+ok(defined Str(0), '... Str accepts anything which is a Str');
+ok(defined Str(100), '... Str accepts anything which is a Str');
+ok(defined Str(''), '... Str accepts anything which is a Str');
+ok(defined Str('Foo'), '... Str accepts anything which is a Str');
+ok(!defined Str([]), '... Str rejects anything which is not a Str');
+ok(!defined Str({}), '... Str rejects anything which is not a Str');
+ok(!defined Str(sub {}), '... Str rejects anything which is not a Str');
+ok(!defined Str($SCALAR_REF), '... Str rejects anything which is not a Str');
+ok(!defined Str($fh), '... Str rejects anything which is not a Str');
+ok(!defined Str($GLOB), '... Str rejects anything which is not a Str');
+ok(!defined Str($GLOB_REF), '... Str rejects anything which is not a Str');
+ok(!defined Str(qr/../), '... Str rejects anything which is not a Str');
+ok(!defined Str(bless {}, 'Foo'), '... Str rejects anything which is not a Str');
+ok(!defined Str(undef), '... Str rejects anything which is not a Str');
+
+ok(!defined ScalarRef(0), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(100), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(''), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef('Foo'), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef([]), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef({}), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(sub {}), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(defined ScalarRef($SCALAR_REF), '... ScalarRef accepts anything which is a ScalarRef');
+ok(!defined ScalarRef($GLOB), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef($GLOB_REF), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef($fh), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(qr/../), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(bless {}, 'Foo'), '... ScalarRef rejects anything which is not a ScalarRef');
+ok(!defined ScalarRef(undef), '... ScalarRef rejects anything which is not a ScalarRef');
+
+ok(!defined ArrayRef(0), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(100), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(''), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef('Foo'), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(defined ArrayRef([]), '... ArrayRef accepts anything which is a ArrayRef');
+ok(!defined ArrayRef({}), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(sub {}), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef($SCALAR_REF), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef($GLOB), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef($GLOB_REF), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef($fh), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(qr/../), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(bless {}, 'Foo'), '... ArrayRef rejects anything which is not a ArrayRef');
+ok(!defined ArrayRef(undef), '... ArrayRef rejects anything which is not a ArrayRef');
+
+ok(!defined HashRef(0), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef(100), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef(''), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef('Foo'), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef([]), '... HashRef rejects anything which is not a HashRef');
+ok(defined HashRef({}), '... HashRef accepts anything which is a HashRef');
+ok(!defined HashRef(sub {}), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef($SCALAR_REF), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef($GLOB), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef($GLOB_REF), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef($fh), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef(qr/../), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef(bless {}, 'Foo'), '... HashRef rejects anything which is not a HashRef');
+ok(!defined HashRef(undef), '... HashRef rejects anything which is not a HashRef');
+
+ok(!defined CodeRef(0), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef(100), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef(''), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef('Foo'), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef([]), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef({}), '... CodeRef rejects anything which is not a CodeRef');
+ok(defined CodeRef(sub {}), '... CodeRef accepts anything which is a CodeRef');
+ok(!defined CodeRef($SCALAR_REF), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef($GLOB), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef($GLOB_REF), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef($fh), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef(qr/../), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef(bless {}, 'Foo'), '... CodeRef rejects anything which is not a CodeRef');
+ok(!defined CodeRef(undef), '... CodeRef rejects anything which is not a CodeRef');
+
+ok(!defined RegexpRef(0), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef(100), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef(''), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef('Foo'), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef([]), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef({}), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef(sub {}), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef($SCALAR_REF), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef($GLOB), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef($GLOB_REF), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef($fh), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(defined RegexpRef(qr/../), '... RegexpRef accepts anything which is a RegexpRef');
+ok(!defined RegexpRef(bless {}, 'Foo'), '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef(undef), '... RegexpRef rejects anything which is not a RegexpRef');
+
+ok(!defined GlobRef(0), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(100), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(''), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef('Foo'), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef([]), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef({}), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(sub {}), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef($SCALAR_REF), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef($GLOB), '... GlobRef rejects anything which is not a GlobRef');
+ok(defined GlobRef($GLOB_REF), '... GlobRef accepts anything which is a GlobRef');
+ok(defined GlobRef($fh), '... GlobRef accepts anything which is a GlobRef');
+ok(!defined GlobRef($fh_obj), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(qr/../), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(bless {}, 'Foo'), '... GlobRef rejects anything which is not a GlobRef');
+ok(!defined GlobRef(undef), '... GlobRef rejects anything which is not a GlobRef');
+
+ok(!defined FileHandle(0), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle(100), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle(''), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle('Foo'), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle([]), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle({}), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle(sub {}), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle($SCALAR_REF), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle($GLOB), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle($GLOB_REF), '... FileHandle rejects anything which is not a FileHandle');
+ok(defined FileHandle($fh), '... FileHandle accepts anything which is a FileHandle');
+ok(defined FileHandle($fh_obj), '... FileHandle accepts anything which is a FileHandle');
+ok(!defined FileHandle(qr/../), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle(bless {}, 'Foo'), '... FileHandle rejects anything which is not a FileHandle');
+ok(!defined FileHandle(undef), '... FileHandle rejects anything which is not a FileHandle');
+
+ok(!defined Object(0), '... Object rejects anything which is not blessed');
+ok(!defined Object(100), '... Object rejects anything which is not blessed');
+ok(!defined Object(''), '... Object rejects anything which is not blessed');
+ok(!defined Object('Foo'), '... Object rejects anything which is not blessed');
+ok(!defined Object([]), '... Object rejects anything which is not blessed');
+ok(!defined Object({}), '... Object rejects anything which is not blessed');
+ok(!defined Object(sub {}), '... Object rejects anything which is not blessed');
+ok(!defined Object($SCALAR_REF), '... Object rejects anything which is not blessed');
+ok(!defined Object($GLOB), '... Object rejects anything which is not blessed');
+ok(!defined Object($GLOB_REF), '... Object rejects anything which is not blessed');
+ok(!defined Object($fh), '... Object rejects anything which is not blessed');
+ok(!defined Object(qr/../), '... Object rejects anything which is not blessed');
+ok(defined Object(bless {}, 'Foo'), '... Object accepts anything which is blessed');
+ok(!defined Object(undef), '... Object accepts anything which is blessed');
+
+ok(!defined ClassName(0), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(100), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(''), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName('Baz'), '... ClassName rejects anything which is not a ClassName');
+
+{
+ package Quux::Wibble; # this makes Quux symbol table exist
+
+ sub foo {}
+}
+
+ok(!defined ClassName('Quux'), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName([]), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName({}), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(sub {}), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName($SCALAR_REF), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName($fh), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName($GLOB), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName($GLOB_REF), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(qr/../), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(bless {}, 'Foo'), '... ClassName rejects anything which is not a ClassName');
+ok(!defined ClassName(undef), '... ClassName rejects anything which is not a ClassName');
+ok(defined ClassName('UNIVERSAL'), '... ClassName accepts anything which is a ClassName');
+ok(defined ClassName('Quux::Wibble'), '... ClassName accepts anything which is a ClassName');
+ok(defined ClassName('Mouse::Meta::TypeConstraint'), '... ClassName accepts anything which is a ClassName');
+
+ok(!defined RoleName(0), '... RoleName rejects anything which is not a RoleName');
+ok(!defined RoleName(100), '... RoleName rejects anything which is not a RoleName');
+ok(!defined RoleName(''), '... RoleName rejects anything which is not a RoleName');
+ok(!defined RoleName('Baz'), '... RoleName rejects anything which is not a RoleName');
+
+{
+ package Quux::Wibble::Role; # this makes Quux symbol table exist
+ use Mouse::Role;
+ sub foo {}
+}
+
+ok(!defined RoleName('Quux'), '... RoleName rejects anything which is not a RoleName');
+ok(!defined RoleName([]), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName({}), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName(sub {}), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName($SCALAR_REF), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName($fh), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName($GLOB), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName($GLOB_REF), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName(qr/../), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName(bless {}, 'Foo'), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName(undef), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName('UNIVERSAL'), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName('Quux::Wibble'), '... Rolename rejects anything which is not a RoleName');
+ok(!defined RoleName('Mouse::Meta::TypeConstraint'), '... RoleName accepts anything which is a RoleName');
+ok(defined RoleName('Quux::Wibble::Role'), '... RoleName accepts anything which is a RoleName');
+
+close($fh) || die "Could not close the filehandle $0 for test";
--- /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 Test::More tests => 26;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Mouse::Util::TypeConstraints');
+}
+
+{
+ package HTTPHeader;
+ use Mouse;
+
+ has 'array' => (is => 'ro');
+ has 'hash' => (is => 'ro');
+}
+
+subtype Header =>
+ => as Object
+ => where { $_->isa('HTTPHeader') };
+
+coerce Header
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
+
+Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
+
+my $header = HTTPHeader->new();
+isa_ok($header, 'HTTPHeader');
+
+ok(Header($header), '... this passed the type test');
+ok(!Header([]), '... this did not pass the type test');
+ok(!Header({}), '... this did not pass the type test');
+
+my $anon_type = subtype Object => where { $_->isa('HTTPHeader') };
+
+lives_ok {
+ coerce $anon_type
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+} 'coercion of anonymous subtype succeeds';
+
+foreach my $coercion (
+ find_type_constraint('Header')->coercion,
+ $anon_type->coercion
+ ) {
+
+ isa_ok($coercion, 'Mouse::Meta::TypeCoercion');
+
+ {
+ my $coerced = $coercion->coerce([ 1, 2, 3 ]);
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->array(),
+ [ 1, 2, 3 ],
+ '... got the right array');
+ is($coerced->hash(), undef, '... nothing assigned to the hash');
+ }
+
+ {
+ my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->hash(),
+ { one => 1, two => 2, three => 3 },
+ '... got the right hash');
+ is($coerced->array(), undef, '... nothing assigned to the array');
+ }
+
+ {
+ my $scalar_ref = \(my $var);
+ my $coerced = $coercion->coerce($scalar_ref);
+ is($coerced, $scalar_ref, '... got back what we put in');
+ }
+
+ {
+ my $coerced = $coercion->coerce("Foo");
+ is($coerced, "Foo", '... got back what we put in');
+ }
+}
+
+subtype 'StrWithTrailingX'
+ => as 'Str'
+ => where { /X$/ };
+
+coerce 'StrWithTrailingX'
+ => from 'Str'
+ => via { $_ . 'X' };
+
+my $tc = find_type_constraint('StrWithTrailingX');
+is($tc->coerce("foo"), "fooX", "coerce when needed");
+is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded");
--- /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 => 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 => 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;
+use Test::Exception;
+
+BEGIN {
+ eval "use IO::String; use IO::File;";
+ plan skip_all => "IO::String and IO::File are required for this test" if $@;
+ plan tests => 28;
+}
+
+
+
+{
+ package Email::Mouse;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ use IO::String;
+
+ our $VERSION = '0.01';
+
+ # create subtype for IO::String
+
+ subtype 'IO::String'
+ => as 'Object'
+ => where { $_->isa('IO::String') };
+
+ coerce 'IO::String'
+ => from 'Str'
+ => via { IO::String->new($_) },
+ => from 'ScalarRef',
+ => via { IO::String->new($_) };
+
+ # create subtype for IO::File
+
+ subtype 'IO::File'
+ => as 'Object'
+ => where { $_->isa('IO::File') };
+
+ coerce 'IO::File'
+ => from 'FileHandle'
+ => via { bless $_, 'IO::File' };
+
+ # create the alias
+
+ subtype 'IO::StringOrFile' => as 'IO::String | IO::File';
+
+ # attributes
+
+ has 'raw_body' => (
+ is => 'rw',
+ isa => 'IO::StringOrFile',
+ coerce => 1,
+ default => sub { IO::String->new() },
+ );
+
+ sub as_string {
+ my ($self) = @_;
+ my $fh = $self->raw_body();
+ return do { local $/; <$fh> };
+ }
+}
+
+{
+ my $email = Email::Mouse->new;
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, undef, '... got correct empty string');
+}
+
+{
+ my $email = Email::Mouse->new(raw_body => '... this is my body ...');
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, '... this is my body ...', '... got correct string');
+
+ lives_ok {
+ $email->raw_body('... this is the next body ...');
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, '... this is the next body ...', '... got correct string');
+}
+
+{
+ my $str = '... this is my body (ref) ...';
+
+ my $email = Email::Mouse->new(raw_body => \$str);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, $str, '... got correct string');
+
+ my $str2 = '... this is the next body (ref) ...';
+
+ lives_ok {
+ $email->raw_body(\$str2);
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, $str2, '... got correct string');
+}
+
+{
+ my $io_str = IO::String->new('... this is my body (IO::String) ...');
+
+ my $email = Email::Mouse->new(raw_body => $io_str);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+ is($email->raw_body, $io_str, '... and it is the one we expected');
+
+ is($email->as_string, '... this is my body (IO::String) ...', '... got correct string');
+
+ my $io_str2 = IO::String->new('... this is the next body (IO::String) ...');
+
+ lives_ok {
+ $email->raw_body($io_str2);
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+ is($email->raw_body, $io_str2, '... and it is the one we expected');
+
+ is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string');
+}
+
+{
+ my $fh;
+
+ open($fh, '<', $0) || die "Could not open $0";
+
+ my $email = Email::Mouse->new(raw_body => $fh);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::File');
+
+ close($fh);
+}
+
+{
+ my $fh = IO::File->new($0);
+
+ my $email = Email::Mouse->new(raw_body => $fh);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::File');
+ is($email->raw_body, $fh, '... and it is the one we expected');
+}
+
+
+
--- /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 => 10;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Mouse::Util::TypeConstraints');
+ use_ok('Mouse::Meta::TypeConstraint::Parameterized');
+}
+
+my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry;
+
+# Array of Ints
+
+my $array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
+ name => 'ArrayRef[Int]',
+ parent => find_type_constraint('ArrayRef'),
+ type_parameter => find_type_constraint('Int'),
+);
+isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
+
+$r->add_type_constraint($array_of_ints);
+
+is(find_type_constraint('ArrayRef[Int]'), $array_of_ints, '... found the type we just added');
+
+# Hash of Ints
+
+my $hash_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
+ name => 'HashRef[Int]',
+ parent => find_type_constraint('HashRef'),
+ type_parameter => find_type_constraint('Int'),
+);
+isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint');
+
+$r->add_type_constraint($hash_of_ints);
+
+is(find_type_constraint('HashRef[Int]'), $hash_of_ints, '... found the type we just added');
+
+## now attempt a coercion
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'ArrayRef[Int]'
+ => from 'HashRef[Int]'
+ => via { [ values %$_ ] };
+
+ has 'bar' => (
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ coerce => 1,
+ );
+
+}
+
+my $foo = Foo->new(bar => { one => 1, two => 2, three => 3 });
+isa_ok($foo, 'Foo');
+
+is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!');
+
+
--- /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;
+
+use Scalar::Util ();
+
+use Mouse::Util::TypeConstraints;
+
+enum Letter => 'a'..'z', 'A'..'Z';
+enum Language => 'Perl 5', 'Perl 6', 'PASM', 'PIR'; # any others? ;)
+enum Metacharacter => ['*', '+', '?', '.', '|', '(', ')', '[', ']', '\\'];
+
+my @valid_letters = ('a'..'z', 'A'..'Z');
+
+my @invalid_letters = qw/ab abc abcd/;
+push @invalid_letters, qw/0 4 9 ~ @ $ %/;
+push @invalid_letters, qw/l33t st3v4n 3num/;
+
+my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR');
+my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++');
+# note that "perl 5" is invalid because case now matters
+
+my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\');
+my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/;
+push @invalid_metacharacters, qw/.* fish(sticks)? atreides/;
+push @invalid_metacharacters, '^1?$|^(11+?)\1+$';
+
+plan tests => @valid_letters + @invalid_letters
+ + @valid_languages + @invalid_languages
+ + @valid_metacharacters + @invalid_metacharacters
+ + @valid_languages + 10;
+
+Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
+
+ok(Letter($_), "'$_' is a letter") for @valid_letters;
+ok(!Letter($_), "'$_' is not a letter") for @invalid_letters;
+
+ok(Language($_), "'$_' is a language") for @valid_languages;
+ok(!Language($_), "'$_' is not a language") for @invalid_languages;
+
+ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters;
+ok(!Metacharacter($_), "'$_' is not a metacharacter")
+ for @invalid_metacharacters;
+
+# check anon enums
+
+my $anon_enum = enum \@valid_languages;
+isa_ok($anon_enum, 'Mouse::Meta::TypeConstraint');
+
+is($anon_enum->name, '__ANON__', '... got the right name');
+is($anon_enum->parent->name, 'Str', '... got the right parent name');
+
+ok($anon_enum->check($_), "'$_' is a language") for @valid_languages;
+
+
+ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" );
+ok( $anon_enum->equals( $anon_enum ), "equals itself" );
+ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" );
+
+ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object');
+ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object');
+
+ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type');
+ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type');
+
--- /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 => 21;
+use Test::Exception;
+
+BEGIN {
+ use_ok("Mouse::Util::TypeConstraints");
+}
+
+lives_ok {
+ subtype 'MyCollections' => as 'ArrayRef | HashRef';
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollections');
+ isa_ok($t, 'Mouse::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollections', '... name is correct');
+
+ my $p = $t->parent;
+ isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
+
+ ok($t->check([]), '... validated it correctly');
+ ok($t->check({}), '... validated it correctly');
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+lives_ok {
+ subtype 'MyCollectionsExtended'
+ => as 'ArrayRef|HashRef'
+ => where {
+ if (ref($_) eq 'ARRAY') {
+ return if scalar(@$_) < 2;
+ }
+ elsif (ref($_) eq 'HASH') {
+ return if scalar(keys(%$_)) < 2;
+ }
+ 1;
+ };
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollectionsExtended');
+ isa_ok($t, 'Mouse::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollectionsExtended', '... name is correct');
+
+ my $p = $t->parent;
+ isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
+
+ ok(!$t->check([]), '... validated it correctly');
+ ok($t->check([1, 2]), '... validated it correctly');
+
+ ok(!$t->check({}), '... validated it correctly');
+ ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
+
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+
--- /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 => 2;
+
+{
+ package SomeClass;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'DigitSix' => as 'Num'
+ => where { /^6$/ };
+ subtype 'TextSix' => as 'Str'
+ => where { /Six/i };
+ coerce 'TextSix'
+ => from 'DigitSix'
+ => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' };
+
+ has foo => (
+ is => 'ro',
+ isa => 'TextSix',
+ coerce => 1,
+ default => 6,
+ lazy => 1
+ );
+}
+
+my $attr = SomeClass->meta->get_attribute('foo');
+is($attr->get_value(SomeClass->new()), 'Six');
+is(SomeClass->new()->foo, 'Six');
+
--- /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';
+
+
+
+
projects / gitmo/Mouse.git / commitdiff