From: Stevan Little Date: Fri, 23 Nov 2007 19:46:00 +0000 (+0000) Subject: fixing stuff X-Git-Tag: 0_32~11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a0f8153dc5f0032469d14b8f96ba0a7be56839e3;p=gitmo%2FMoose.git fixing stuff --- diff --git a/Changes b/Changes index fcbdf40..96bd331 100644 --- a/Changes +++ b/Changes @@ -10,6 +10,10 @@ Revision history for Perl extension Moose * Moose::Util::TypeConstraints - fix ClassName constraint to introspect symbol table (mst) + - added more tests for this (mst) + - fixed it so that subtype 'Foo' => as 'HashRef[Int]' ... + with work correctly. + - added tests for this * t/ - New tests for builder bug. Upon instantiation, if an diff --git a/MANIFEST b/MANIFEST index 814f814..d43b1b1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -106,6 +106,7 @@ t/040_type_constraints/012_container_type_coercion.t t/040_type_constraints/013_advanced_type_creation.t t/040_type_constraints/014_type_notation_parser.t t/040_type_constraints/015_enum.t +t/040_type_constraints/016_subtyping_parameterized_types.t t/050_metaclasses/001_custom_attr_meta_with_roles.t t/050_metaclasses/002_custom_attr_meta_as_role.t t/050_metaclasses/003_moose_w_metaclass.t diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 149c81b..f144a57 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype'; use B 'svref_2object'; use Sub::Exporter; -our $VERSION = '0.15'; +our $VERSION = '0.16'; our $AUTHORITY = 'cpan:STEVAN'; ## -------------------------------------------------------- @@ -93,10 +93,10 @@ sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} } sub export_type_constraints_as_functions { my $pkg = caller(); no strict 'refs'; - foreach my $constraint (keys %{$REGISTRY->type_constraints}) { - *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) - ->_compiled_type_constraint; - } + foreach my $constraint (keys %{$REGISTRY->type_constraints}) { + *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) + ->_compiled_type_constraint; + } } sub create_type_constraint_union (@) { @@ -190,7 +190,7 @@ sub find_type_constraint ($) { $REGISTRY->get_type_constraint(@_) } sub type ($$;$$) { splice(@_, 1, 0, undef); - goto &_create_type_constraint; + goto &_create_type_constraint; } sub subtype ($$;$$$) { @@ -203,8 +203,8 @@ sub subtype ($$;$$$) { # subtype(MyNumbers => as Num); # now MyNumbers is the same as Num # ... yeah I know it's ugly code # - SL - unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE'; - goto &_create_type_constraint; + unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE'; + goto &_create_type_constraint; } sub coerce ($@) { @@ -225,11 +225,11 @@ sub enum ($;@) { (scalar @values >= 2) || confess "You must have at least two values to enumerate through"; my %valid = map { $_ => 1 } @values; - _create_type_constraint( - $type_name, - 'Str', - sub { $valid{$_} } - ); + _create_type_constraint( + $type_name, + 'Str', + sub { $valid{$_} } + ); } ## -------------------------------------------------------- @@ -259,7 +259,7 @@ sub _create_type_constraint ($$$;$$) { if defined $type; } - $parent = $REGISTRY->get_type_constraint($parent) if defined $parent; + $parent = find_or_create_type_constraint($parent) if defined $parent; my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', diff --git a/t/040_type_constraints/005_util_type_coercion.t b/t/040_type_constraints/005_util_type_coercion.t index 4fb8c55..e631309 100644 --- a/t/040_type_constraints/005_util_type_coercion.t +++ b/t/040_type_constraints/005_util_type_coercion.t @@ -28,20 +28,6 @@ coerce Header => from HashRef => via { HTTPHeader->new(hash => $_[0]) }; - -{ - package Math::BigFloat; - sub new { bless { }, shift }; # not a moose class ;-) -} - -subtype "Math::BigFloat" - => as "Math::BigFloat" - => where { 1 }; - -coerce "Math::BigFloat" - => from Num - => via { Math::BigFloat->new( $_ ) }; - Moose::Util::TypeConstraints->export_type_constraints_as_functions(); diff --git a/t/040_type_constraints/016_subtyping_parameterized_types.t b/t/040_type_constraints/016_subtyping_parameterized_types.t new file mode 100644 index 0000000..2462c14 --- /dev/null +++ b/t/040_type_constraints/016_subtyping_parameterized_types.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 18; +use Test::Exception; + +BEGIN { + use_ok("Moose::Util::TypeConstraints"); +} + +lives_ok { + subtype 'MySpecialHash' => as 'HashRef[Int]'; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MySpecialHash'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHash', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'HashRef[Int]', '... parent name is correct'); + + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); +} + +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, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MySpecialHashExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Parameterized'); + isa_ok($p, 'Moose::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 it correctly'); + ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly'); +} +