From: Vincent Pit Date: Sat, 31 Jul 2010 12:36:00 +0000 (+0200) Subject: Allow passing a type constraint as the parent to LT::Meta::TypeConstraint::Autocoerce X-Git-Tag: v0.02~23 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=8b77cfe7dbee01186e578c4037737e2895edea87;p=perl%2Fmodules%2FLaTeX-TikZ.git Allow passing a type constraint as the parent to LT::Meta::TypeConstraint::Autocoerce --- diff --git a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm index 521a473..9c65f36 100644 --- a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm +++ b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm @@ -15,9 +15,12 @@ Version 0.01 our $VERSION = '0.01'; +use Scalar::Util qw/blessed/; + use Sub::Name (); use Any::Moose; +use Any::Moose 'Util' => [ 'find_meta' ]; extends any_moose('Meta::TypeConstraint'); @@ -32,13 +35,13 @@ has 'mapper' => ( isa => 'CodeRef', ); -=head2 C +=head2 C =cut -has 'parent_name' => ( +has 'parent' => ( is => 'ro', - isa => 'ClassName', + isa => any_moose('Meta::TypeConstraint'), required => 1, ); @@ -60,23 +63,23 @@ around 'new' => sub { my ($orig, $class, %args) = @_; unless (exists $args{mapper}) { - $args{mapper} = sub { join '::', $_[0]->parent_name, $_[1] }; + $args{mapper} = sub { join '::', $_[0]->parent->name, $_[1] }; } my $parent = delete $args{parent}; - $args{parent_name} = defined $parent - ? (blessed($parent) ? $parent->name : $parent) - : '__ANON__'; + unless (blessed $parent) { + $parent = find_meta($parent)->type_constraint; + } + __PACKAGE__->meta->find_attribute_by_name('parent') + ->type_constraint->assert_valid($parent); + $args{parent} = $parent; - $args{user_constraint} = $args{constraint}; + $args{user_constraint} = delete $args{constraint}; if (any_moose() eq 'Moose') { $args{coercion} = Moose::Meta::TypeCoercion->new; } - my $parent_name = $args{parent_name}; - $parent_name =~ s/::+/_/g; - my $tc; $args{constraint} = Sub::Name::subname('_load' => sub { $tc->load(@_); @@ -92,6 +95,10 @@ around 'new' => sub { sub load { my ($tc, $thing) = @_; + # When ->check is called inside coerce, a return value of 0 means that + # coercion should take place, while 1 signifies that the value is already + # OK. + # First, try a possible user defined constraint my $user = $tc->user_constraint; if (defined $user) { @@ -99,17 +106,16 @@ sub load { return 1 if $ok; } - # When ->check is called inside coerce, a return value of 0 means that - # coercion should take place, while 1 signifies that the value is already - # OK. + # Then, try the parent constraint + return 1 if $tc->parent->check($thing); + # If $thing isn't even an object, don't bother trying to coerce it my $class = blessed($thing); - return 0 unless $class; - return 1 if $class->isa($tc->parent_name); + return 0 unless defined $class; + # Find the file to autoload my $mapper = $tc->mapper; my $pm = $class = $tc->$mapper($class); - $pm =~ s{::}{/}g; $pm .= '.pm'; return 0 if $INC{$pm}; # already loaded