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