Fix the autocoercing code with recent versions of Moose

[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 136940d23d3008f3e32dd7549af9444a6efce074..7671ade74ddbca7fb9538992ac72bb45ed295e75 100644 (file)
--- a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
+++ b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm
@@ -9,11 +9,11 @@ LaTeX::TikZ::Meta::TypeConstraint::Autocoerce - Type constraint metaclass that a
 
 =head1 VERSION
 
-Version 0.01
+Version 0.02
 
 =cut
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 =head1 SYNOPSIS
 
@@ -30,7 +30,7 @@ our $VERSION = '0.01';
      register_type_constraint(
       LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
        name   => 'X::Autocoerce',
-       parent => find_type_constraint(__PACKAGE__),
+       target => find_type_constraint(__PACKAGE__),
        mapper => sub { join '::', __PACKAGE__, 'From', $_[1] },
       );
      );
@@ -47,7 +47,9 @@ our $VERSION = '0.01';
       coerce  => 1,
       handles => [ 'id' ],
      );
-     __PACKAGE__->meta->make_immutable;
+     # This class shouldn't be immutable when using Moose, or the
+     # coercing attributes will not be updated with the future coercions.
+     __PACKAGE__->meta->make_immutable if any_moose() ne 'Moose';
     }
 
     # Another class the user wants to use instead of X (cannot be changed)
@@ -76,7 +78,7 @@ our $VERSION = '0.01';
 
 =head1 DESCRIPTION
 
-This type constraint metaclass tries to autoload a specific module when a type coercion is attempted, which is supposed to contain the actual coercion code.
+When a type coercion is attempted, this type constraint metaclass tries to autoload a specific module which is supposed to contain the actual coercion code.
 This allows you to declare types that can be replaced (through coercion) at the end user's discretion.
 
 It works with both L<Moose> and L<Mouse> by using L<Any::Moose>.
@@ -85,12 +87,13 @@ Note that you will need L<Moose::Util::TypeConstraints/register_type_constraint>
 
 =cut
 
-use Scalar::Util qw/blessed/;
+use Scalar::Util qw<blessed>;
 
 use Sub::Name ();
 
+use LaTeX::TikZ::Tools;
+
 use Any::Moose;
-use Any::Moose 'Util' => [ 'find_meta' ];
 
 =head1 RELATIONSHIPS
 
@@ -122,36 +125,28 @@ has 'mapper' => (
  required => 1,
 );
 
-=head2 C<parent>
+=head2 C<target>
 
-A type constraint that defines which objects are already valid and do not need to be coerced.
-This is somewhat different from L<Moose::Meta::TypeConstraint/parent>.
+A type constraint that defines into what the objects are going to be coerced.
+Objects satisfying this type constraint will be automatically considered as valid and will not be coerced.
 If it is given as a plain string, then a type constraint with the same name is searched for in the global type constraint registry.
 
 =cut
 
-has 'parent' => (
+has 'target' => (
  is       => 'ro',
  isa      => any_moose('Meta::TypeConstraint'),
  required => 1,
 );
 
-=head2 C<user_constraint>
-
-An optional user defined code reference which predates checking the parent for validity.
-
-=cut
-
-has 'user_constraint' => (
- is  => 'ro',
- isa => 'Maybe[CodeRef]',
-);
+my $target_tc = __PACKAGE__->meta->find_attribute_by_name('target')
+                                 ->type_constraint;
 
 =head1 METHODS
 
-=head2 C<< new name => $name, mapper => $mapper, parent => $parent, [ user_constraint => sub { ... } ] >>
+=head2 C<< new name => $name, mapper => $mapper, target => $target >>
 
-Constructs a type constraint object that will attempt to autocoerce objects that are not valid according to C<$parent> by loading the class returned by C<$mapper>.
+Constructs a type constraint object that will attempt to autocoerce objects that are not valid according to C<$target> by loading the class returned by C<$mapper>.
 
 =cut
 
@@ -159,43 +154,34 @@ around 'new' => sub {
  my ($orig, $class, %args) = @_;
 
  unless (exists $args{mapper}) {
-  $args{mapper} = sub { join '::', $_[0]->parent->name, $_[1] };
+  $args{mapper} = sub { join '::', $_[0]->target->name, $_[1] };
  }
 
- my $parent = delete $args{parent};
- unless (defined $parent and blessed $parent) {
-  $parent = find_meta($parent);
-  Carp::confess("No meta object for parent $parent");
-  $parent = $parent->type_constraint;
+ my $target = delete $args{target};
+ unless (blessed $target) {
+  my $target_name = defined $target ? "target $target" : 'undefined target';
+  $target = LaTeX::TikZ::Tools::type_constraint($target) if defined $target;
+  Carp::confess("No meta object for $target_name")   unless defined $target;
  }
- __PACKAGE__->meta->find_attribute_by_name('parent')
-                  ->type_constraint->assert_valid($parent);
- $args{parent} = $parent;
+ $target_tc->assert_valid($target);
+ $args{target} = $target;
 
  if (any_moose() eq 'Moose') {
   $args{coercion} = Moose::Meta::TypeCoercion->new;
  }
 
- my $tc;
  $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;
-  }
+  # already OK. Thus we should return true if and only if $thing passes the
+  # target type constraint.
 
-  # Then, it's valid if and only if it passes the parent type constraint
-  return $tc->parent->check($thing);
+  return $target->check($thing);
  });
 
- $tc = $class->$orig(%args);
+ return $class->$orig(%args);
 };
 
 =head2 C<coerce $thing>