package LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;

use strict;
use warnings;

=head1 NAME

LaTeX::TikZ::Meta::TypeConstraint::Autocoerce - Type constraint metaclass that autoloads type coercions.

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

use Sub::Name ();

use Any::Moose;

extends any_moose('Meta::TypeConstraint');

has 'mapper' => (
 is  => 'ro',
 isa => 'CodeRef',
);

has 'parent_name' => (
 is       => 'ro',
 isa      => 'ClassName',
 required => 1,
);

has 'user_constraint' => (
 is       => 'ro',
 isa      => 'Maybe[CodeRef]',
 required => 1,
);

around 'new' => sub {
 my ($orig, $class, %args) = @_;

 unless (exists $args{mapper}) {
  $args{mapper} = sub { join '::', $_[0]->parent_name, $_[1] };
 }

 my $parent = delete $args{parent};
 $args{parent_name} = defined $parent
                      ? (blessed($parent) ? $parent->name : $parent)
                      : '__ANON__';

 $args{user_constraint} = $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 {
  my ($thing) = @_;

  # First, try a possible user defined constraint
  my $user = $tc->user_constraint;
  if (defined $user) {
   my $ok = $user->($thing);
   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;
 });

 $tc = $class->$orig(%args);
};

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 ->check.
 return $thing if $tc->check($thing);

 $tc->$orig($thing);
};

__PACKAGE__->meta->make_immutable(
 inline_constructor => 0,
);

=head1 AUTHOR

Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.

You can contact me by mail or on C<irc.perl.org> (vincent).

=head1 BUGS

Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc LaTeX::TikZ

=head1 COPYRIGHT & LICENSE

Copyright 2010 Vincent Pit, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut

1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce
