From: Vincent Pit <vince@profvince.com>
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/?p=perl%2Fmodules%2FLaTeX-TikZ.git;a=commitdiff_plain;h=8b77cfe7dbee01186e578c4037737e2895edea87

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<parent_name>
+=head2 C<parent>
 
 =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