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 Scalar::Util qw/blessed/;
  19
  20 use Sub::Name ();
  21
  22 use Any::Moose;
  23 use Any::Moose 'Util' => [ 'find_meta' ];
  24
  25 extends any_moose('Meta::TypeConstraint');
  26
  27 =head1 ATTRIBUTES
  28
  29 =head2 C<mapper>
  30
  31 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.
  32 It is called with the type constraint object as first argument, followed by the class name.
  33
  34 =cut
  35
  36 has 'mapper' => (
  37  is       => 'ro',
  38  isa      => 'CodeRef',
  39  required => 1,
  40 );
  41
  42 =head2 C<parent>
  43
  44 =cut
  45
  46 has 'parent' => (
  47  is       => 'ro',
  48  isa      => any_moose('Meta::TypeConstraint'),
  49  required => 1,
  50 );
  51
  52 =head2 C<user_constraint>
  53
  54 =cut
  55
  56 has 'user_constraint' => (
  57  is       => 'ro',
  58  isa      => 'Maybe[CodeRef]',
  59  required => 1,
  60 );
  61
  62 =head1 METHODS
  63
  64 =cut
  65
  66 around 'new' => sub {
  67  my ($orig, $class, %args) = @_;
  68
  69  unless (exists $args{mapper}) {
  70   $args{mapper} = sub { join '::', $_[0]->parent->name, $_[1] };
  71  }
  72
  73  my $parent = delete $args{parent};
  74  unless (blessed $parent) {
  75   $parent = find_meta($parent)->type_constraint;
  76  }
  77  __PACKAGE__->meta->find_attribute_by_name('parent')
  78                   ->type_constraint->assert_valid($parent);
  79  $args{parent} = $parent;
  80
  81  $args{user_constraint} = delete $args{constraint};
  82
  83  if (any_moose() eq 'Moose') {
  84   $args{coercion} = Moose::Meta::TypeCoercion->new;
  85  }
  86
  87  my $tc;
  88  $args{constraint} = Sub::Name::subname('_constraint' => sub {
  89   my ($thing) = @_;
  90
  91   # Remember that when ->check is called inside coerce, a return value of 0
  92   # means that coercion should take place, while 1 signifies that the value is
  93   # already OK.
  94
  95   # First, try a possible user defined constraint
  96   my $user = $tc->user_constraint;
  97   if (defined $user) {
  98    my $ok = $user->($thing);
  99    return 1 if $ok;
 100   }
 101
 102   # Then, it's valid if and only if it passes the parent type constraint
 103   return $tc->parent->check($thing);
 104  });
 105
 106  $tc = $class->$orig(%args);
 107 };
 108
 109 around 'coerce' => sub {
 110  my ($orig, $tc, $thing) = @_;
 111
 112  # The original coerce gets an hold onto the type coercions *before* calling
 113  # the constraint. Thus, we have to force the loading before recalling into
 114  # $orig.
 115
 116  # First, check whether $thing is already of the right kind.
 117  return $thing if $tc->check($thing);
 118
 119  # If $thing isn't even an object, don't bother trying to autoload a coercion
 120  my $class = blessed($thing);
 121  if (defined $class) {
 122   $class = $tc->mapper->($tc, $class);
 123
 124   if (defined $class) {
 125    # Find the file to autoload
 126    (my $pm = $class) =~ s{::}{/}g;
 127    $pm .= '.pm';
 128
 129    unless ($INC{$pm}) { # Not loaded yet
 130     local $@;
 131     eval {
 132      # We die often here, even though we're not really interested in the error.
 133      # However, if a die handler is set (e.g. to \&Carp::confess), this can get
 134      # very slow. Resetting the handler shows a 10% total time improvement for
 135      # the geodyn app.
 136      local $SIG{__DIE__};
 137      require $pm;
 138     };
 139    }
 140   }
 141  }
 142
 143  $tc->$orig($thing);
 144 };
 145
 146 __PACKAGE__->meta->make_immutable(
 147  inline_constructor => 0,
 148 );
 149
 150 =head1 AUTHOR
 151
 152 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 153
 154 You can contact me by mail or on C<irc.perl.org> (vincent).
 155
 156 =head1 BUGS
 157
 158 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>.
 159 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 160
 161 =head1 SUPPORT
 162
 163 You can find documentation for this module with the perldoc command.
 164
 165     perldoc LaTeX::TikZ
 166
 167 =head1 COPYRIGHT & LICENSE
 168
 169 Copyright 2010 Vincent Pit, all rights reserved.
 170
 171 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 172
 173 =cut
 174
 175 1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce