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 =head1 ATTRIBUTES
  25
  26 =head2 C<mapper>
  27
  28 =cut
  29
  30 has 'mapper' => (
  31  is  => 'ro',
  32  isa => 'CodeRef',
  33 );
  34
  35 =head2 C<parent_name>
  36
  37 =cut
  38
  39 has 'parent_name' => (
  40  is       => 'ro',
  41  isa      => 'ClassName',
  42  required => 1,
  43 );
  44
  45 =head2 C<user_constraint>
  46
  47 =cut
  48
  49 has 'user_constraint' => (
  50  is       => 'ro',
  51  isa      => 'Maybe[CodeRef]',
  52  required => 1,
  53 );
  54
  55 =head1 METHODS
  56
  57 =cut
  58
  59 around 'new' => sub {
  60  my ($orig, $class, %args) = @_;
  61
  62  unless (exists $args{mapper}) {
  63   $args{mapper} = sub { join '::', $_[0]->parent_name, $_[1] };
  64  }
  65
  66  my $parent = delete $args{parent};
  67  $args{parent_name} = defined $parent
  68                       ? (blessed($parent) ? $parent->name : $parent)
  69                       : '__ANON__';
  70
  71  $args{user_constraint} = $args{constraint};
  72
  73  if (any_moose() eq 'Moose') {
  74   $args{coercion} = Moose::Meta::TypeCoercion->new;
  75  }
  76
  77  my $parent_name = $args{parent_name};
  78  $parent_name =~ s/::+/_/g;
  79
  80  my $tc;
  81  $args{constraint} = Sub::Name::subname('_load' => sub {
  82   $tc->load(@_);
  83  });
  84
  85  $tc = $class->$orig(%args);
  86 };
  87
  88 =head2 C<load>
  89
  90 =cut
  91
  92 sub load {
  93  my ($tc, $thing) = @_;
  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  # When ->check is called inside coerce, a return value of 0 means that
 103  # coercion should take place, while 1 signifies that the value is already
 104  # OK.
 105
 106  my $class = blessed($thing);
 107  return 0 unless $class;
 108  return 1 if     $class->isa($tc->parent_name);
 109
 110  my $mapper = $tc->mapper;
 111  my $pm = $class = $tc->$mapper($class);
 112
 113  $pm =~ s{::}{/}g;
 114  $pm .= '.pm';
 115  return 0 if $INC{$pm}; # already loaded
 116
 117  local $@;
 118  eval { require $pm; 1 };
 119
 120  return 0;
 121 }
 122
 123 around 'coerce' => sub {
 124  my ($orig, $tc, $thing) = @_;
 125
 126  # The original coerce gets an hold onto the type coercions *before* calling
 127  # the constraint. Thus, we have to force the loading before recalling into
 128  # $orig. This is achieved by calling ->load.
 129  return $thing if $tc->load($thing);
 130
 131  $tc->$orig($thing);
 132 };
 133
 134 __PACKAGE__->meta->make_immutable(
 135  inline_constructor => 0,
 136 );
 137
 138 =head1 AUTHOR
 139
 140 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 141
 142 You can contact me by mail or on C<irc.perl.org> (vincent).
 143
 144 =head1 BUGS
 145
 146 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>.
 147 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 148
 149 =head1 SUPPORT
 150
 151 You can find documentation for this module with the perldoc command.
 152
 153     perldoc LaTeX::TikZ
 154
 155 =head1 COPYRIGHT & LICENSE
 156
 157 Copyright 2010 Vincent Pit, all rights reserved.
 158
 159 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 160
 161 =cut
 162
 163 1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce