lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm

   1 package LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce - Type constraint metaclass that autoloads type coercions.
   9
  10 =head1 VERSION
  11
  12 Version 0.01
  13
  14 =cut
  15
  16 our $VERSION = '0.01';
  17
  18 use Sub::Name ();
  19
  20 use Any::Moose;
  21
  22 extends any_moose('Meta::TypeConstraint');
  23
  24 has 'mapper' => (
  25  is  => 'ro',
  26  isa => 'CodeRef',
  27 );
  28
  29 has 'parent_name' => (
  30  is       => 'ro',
  31  isa      => 'ClassName',
  32  required => 1,
  33 );
  34
  35 has 'user_constraint' => (
  36  is       => 'ro',
  37  isa      => 'Maybe[CodeRef]',
  38  required => 1,
  39 );
  40
  41 around 'new' => sub {
  42  my ($orig, $class, %args) = @_;
  43
  44  unless (exists $args{mapper}) {
  45   $args{mapper} = sub { join '::', $_[0]->parent_name, $_[1] };
  46  }
  47
  48  my $parent = delete $args{parent};
  49  $args{parent_name} = defined $parent
  50                       ? (blessed($parent) ? $parent->name : $parent)
  51                       : '__ANON__';
  52
  53  $args{user_constraint} = $args{constraint};
  54
  55  if (any_moose() eq 'Moose') {
  56   $args{coercion} = Moose::Meta::TypeCoercion->new;
  57  }
  58
  59  my $parent_name = $args{parent_name};
  60  $parent_name =~ s/::+/_/g;
  61
  62  my $tc;
  63  $args{constraint} = Sub::Name::subname("${parent_name}_load" => sub {
  64   my ($thing) = @_;
  65
  66   # First, try a possible user defined constraint
  67   my $user = $tc->user_constraint;
  68   if (defined $user) {
  69    my $ok = $user->($thing);
  70    return 1 if $ok;
  71   }
  72
  73   # When ->check is called inside coerce, a return value of 0 means that
  74   # coercion should take place, while 1 signifies that the value is already
  75   # OK.
  76
  77   my $class = blessed($thing);
  78   return 0 unless $class;
  79   return 1 if     $class->isa($tc->parent_name);
  80
  81   my $mapper = $tc->mapper;
  82   my $pm = $class = $tc->$mapper($class);
  83
  84   $pm =~ s{::}{/}g;
  85   $pm .= '.pm';
  86   return 0 if $INC{$pm}; # already loaded
  87
  88   local $@;
  89   eval { require $pm; 1 };
  90
  91   return 0;
  92  });
  93
  94  $tc = $class->$orig(%args);
  95 };
  96
  97 around 'coerce' => sub {
  98  my ($orig, $tc, $thing) = @_;
  99
 100  # The original coerce gets an hold onto the type coercions *before* calling
 101  # the constraint. Thus, we have to force the loading before recalling into
 102  # $orig. This is achieved by calling ->check.
 103  return $thing if $tc->check($thing);
 104
 105  $tc->$orig($thing);
 106 };
 107
 108 __PACKAGE__->meta->make_immutable(
 109  inline_constructor => 0,
 110 );
 111
 112 =head1 AUTHOR
 113
 114 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 115
 116 You can contact me by mail or on C<irc.perl.org> (vincent).
 117
 118 =head1 BUGS
 119
 120 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>.
 121 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 122
 123 =head1 SUPPORT
 124
 125 You can find documentation for this module with the perldoc command.
 126
 127     perldoc LaTeX::TikZ
 128
 129 =head1 COPYRIGHT & LICENSE
 130
 131 Copyright 2010 Vincent Pit, all rights reserved.
 132
 133 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 134
 135 =cut
 136
 137 1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce