X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FLaTeX%2FTikZ%2FMeta%2FTypeConstraint%2FAutocoerce.pm;h=36efdf19e6e54e91ecb7f90e47e3f268927d1082;hb=c6ce52b9f723406dc94140753f89dab14d846778;hp=4706998ef34e0610da97cdbf8da8073b55584ff8;hpb=abde159aad84169c3dbf1aabd21c9d1bf81acf85;p=perl%2Fmodules%2FLaTeX-TikZ.git

diff --git a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
index 4706998..36efdf1 100644
--- a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
+++ b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
@@ -15,54 +15,83 @@ 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');
 
+=head1 ATTRIBUTES
+
+=head2 C<mapper>
+
+A code reference that maps an object class name to the name of the package in which the coercion can be found, or C<undef> to disable coercion for this class name.
+It is called with the type constraint object as first argument, followed by the class name.
+
+=cut
+
 has 'mapper' => (
- is  => 'ro',
- isa => 'CodeRef',
+ is       => 'ro',
+ isa      => 'CodeRef',
+ required => 1,
 );
 
-has 'parent_name' => (
+=head2 C<parent>
+
+=cut
+
+has 'parent' => (
  is       => 'ro',
- isa      => 'ClassName',
+ isa      => any_moose('Meta::TypeConstraint'),
  required => 1,
 );
 
+=head2 C<user_constraint>
+
+=cut
+
 has 'user_constraint' => (
  is       => 'ro',
  isa      => 'Maybe[CodeRef]',
  required => 1,
 );
 
+=head1 METHODS
+
+=cut
+
 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("${parent_name}_load" => sub {
+ $args{constraint} = Sub::Name::subname('_constraint' => sub {
   my ($thing) = @_;
 
+  # Remember that 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) {
@@ -70,25 +99,8 @@ around 'new' => sub {
    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.
-
-  my $class = blessed($thing);
-  return 0 unless $class;
-  return 1 if     $class->isa($tc->parent_name);
-
-  my $mapper = $tc->mapper;
-  my $pm = $class = $tc->$mapper($class);
-
-  $pm =~ s{::}{/}g;
-  $pm .= '.pm';
-  return 0 if $INC{$pm}; # already loaded
-
-  local $@;
-  eval { require $pm; 1 };
-
-  return 0;
+  # Then, it's valid if and only if it passes the parent type constraint
+  return $tc->parent->check($thing);
  });
 
  $tc = $class->$orig(%args);
@@ -99,9 +111,35 @@ around 'coerce' => sub {
 
  # The original coerce gets an hold onto the type coercions *before* calling
  # the constraint. Thus, we have to force the loading before recalling into
- # $orig. This is achieved by calling ->check.
+ # $orig.
+
+ # First, check whether $thing is already of the right kind.
  return $thing if $tc->check($thing);
 
+ # If $thing isn't even an object, don't bother trying to autoload a coercion
+ my $class = blessed($thing);
+ if (defined $class) {
+  $class = $tc->mapper->($tc, $class);
+
+  if (defined $class) {
+   # Find the file to autoload
+   (my $pm = $class) =~ s{::}{/}g;
+   $pm .= '.pm';
+
+   unless ($INC{$pm}) { # Not loaded yet
+    local $@;
+    eval {
+     # We die often here, even though we're not really interested in the error.
+     # However, if a die handler is set (e.g. to \&Carp::confess), this can get
+     # very slow. Resetting the handler shows a 10% total time improvement for
+     # the geodyn app.
+     local $SIG{__DIE__};
+     require $pm;
+    };
+   }
+  }
+ }
+
  $tc->$orig($thing);
 };