Require the mapper attribute

[perl/modules/LaTeX-TikZ.git] / lib / LaTeX / TikZ / Meta / TypeConstraint / Autocoerce.pm

diff --git a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
index 9c65f364c181cbcd19bfdbeed1e4802ef2e74f49..36efdf19e6e54e91ecb7f90e47e3f268927d1082 100644 (file)
--- a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
+++ b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
@@ -28,11 +28,15 @@ extends any_moose('Meta::TypeConstraint');
 
 =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,
 );
 
 =head2 C<parent>
@@ -81,58 +85,60 @@ around 'new' => sub {
  }
 
  my $tc;
- $args{constraint} = Sub::Name::subname('_load' => sub {
-  $tc->load(@_);
+ $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) {
+   my $ok = $user->($thing);
+   return 1 if $ok;
+  }
+
+  # Then, it's valid if and only if it passes the parent type constraint
+  return $tc->parent->check($thing);
  });
 
  $tc = $class->$orig(%args);
 };
 
-=head2 C<load>
-
-=cut
-
-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) {
-  my $ok = $user->($thing);
-  return 1 if $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 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
-
- local $@;
- eval { require $pm; 1 };
-
- return 0;
-}
-
 around 'coerce' => sub {
  my ($orig, $tc, $thing) = @_;
 
  # 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 ->load.
- return $thing if $tc->load($thing);
+ # $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);
 };