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.02
  13
  14 =cut
  15
  16 our $VERSION = '0.02';
  17
  18 =head1 SYNOPSIS
  19
  20     # The target class of the autocoercion (cannot be changed)
  21     {
  22      package X;
  23      use Any::Moose;
  24      has 'id' => (
  25       is  => 'ro',
  26       isa => 'Int',
  27      );
  28      use LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
  29      use Any::Moose 'Util::TypeConstraints';
  30      register_type_constraint(
  31       LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  32        name   => 'X::Autocoerce',
  33        target => find_type_constraint(__PACKAGE__),
  34        mapper => sub { join '::', __PACKAGE__, 'From', $_[1] },
  35       );
  36      );
  37      __PACKAGE__->meta->make_immutable;
  38     }
  39
  40     # The class that does the coercion (cannot be changed)
  41     {
  42      package Y;
  43      use Any::Moose;
  44      has 'x' => (
  45       is      => 'ro',
  46       isa     => 'X::Autocoerce',
  47       coerce  => 1,
  48       handles => [ 'id' ],
  49      );
  50      # This class shouldn't be immutable when using Moose, or the
  51      # coercing attributes will not be updated with the future coercions.
  52      __PACKAGE__->meta->make_immutable if any_moose() ne 'Moose';
  53     }
  54
  55     # Another class the user wants to use instead of X (cannot be changed)
  56     {
  57      package Z;
  58      use Any::Moose;
  59      has 'id' => (
  60       is  => 'ro',
  61       isa => 'Num',
  62      );
  63      __PACKAGE__->meta->make_immutable;
  64     }
  65
  66     # The autocoercion class, defined by the user in X/From/Z.pm
  67     {
  68      package X::From::Z;
  69      use Any::Moose 'Util::TypeConstraints';
  70      coerce 'X::Autocoerce'
  71          => from 'Z'
  72          => via { X->new(id => int $_->id) };
  73     }
  74
  75     my $z = Z->new(id => 123);
  76     my $y = Y->new(x => $z);
  77     print $y->id; # 123
  78
  79 =head1 DESCRIPTION
  80
  81 When a type coercion is attempted, this type constraint metaclass tries to autoload a specific module which is supposed to contain the actual coercion code.
  82 This allows you to declare types that can be replaced (through coercion) at the end user's discretion.
  83
  84 It works with both L<Moose> and L<Mouse> by using L<Any::Moose>.
  85
  86 Note that you will need L<Moose::Util::TypeConstraints/register_type_constraint> or L<Mouse::Util::TypeConstraints/register_type_constraint> to install this type constraint, and that the latter is only available starting L<Mouse> C<0.63>.
  87
  88 =cut
  89
  90 use Scalar::Util qw<blessed>;
  91
  92 use Sub::Name ();
  93
  94 use LaTeX::TikZ::Tools;
  95
  96 use Any::Moose;
  97
  98 =head1 RELATIONSHIPS
  99
 100 This class inherits from L<Moose::Meta::TypeConstraint> or L<Mouse::Meta::TypeConstraint>, depending on which mode L<Any::Moose> runs.
 101
 102 =cut
 103
 104 extends any_moose('Meta::TypeConstraint');
 105
 106 =head1 ATTRIBUTES
 107
 108 =head2 C<name>
 109
 110 The name of the type constraint.
 111 This must be the target of both the classes that want to use the autocoercion feature and the user defined coercions in the autoloaded classes.
 112
 113 This attribute is inherited from the L<Moose> or L<Mouse> type constraint metaclass.
 114
 115 =head2 C<mapper>
 116
 117 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.
 118 It is called with the type constraint object as first argument, followed by the class name.
 119
 120 =cut
 121
 122 has 'mapper' => (
 123  is       => 'ro',
 124  isa      => 'CodeRef',
 125  required => 1,
 126 );
 127
 128 =head2 C<target>
 129
 130 A type constraint that defines into what the objects are going to be coerced.
 131 Objects satisfying this type constraint will be automatically considered as valid and will not be coerced.
 132 If it is given as a plain string, then a type constraint with the same name is searched for in the global type constraint registry.
 133
 134 =cut
 135
 136 has 'target' => (
 137  is       => 'ro',
 138  isa      => any_moose('Meta::TypeConstraint'),
 139  required => 1,
 140 );
 141
 142 my $target_tc = __PACKAGE__->meta->find_attribute_by_name('target')
 143                                  ->type_constraint;
 144
 145 =head1 METHODS
 146
 147 =head2 C<< new name => $name, mapper => $mapper, target => $target >>
 148
 149 Constructs a type constraint object that will attempt to autocoerce objects that are not valid according to C<$target> by loading the class returned by C<$mapper>.
 150
 151 =cut
 152
 153 around 'new' => sub {
 154  my ($orig, $class, %args) = @_;
 155
 156  unless (exists $args{mapper}) {
 157   $args{mapper} = sub { join '::', $_[0]->target->name, $_[1] };
 158  }
 159
 160  my $target = delete $args{target};
 161  unless (blessed $target) {
 162   my $target_name = defined $target ? "target $target" : 'undefined target';
 163   $target = LaTeX::TikZ::Tools::type_constraint($target) if defined $target;
 164   Carp::confess("No meta object for $target_name")   unless defined $target;
 165  }
 166  $target_tc->assert_valid($target);
 167  $args{target} = $target;
 168
 169  if (any_moose() eq 'Moose') {
 170   $args{coercion} = Moose::Meta::TypeCoercion->new;
 171  }
 172
 173  $args{constraint} = Sub::Name::subname('_constraint' => sub {
 174   my ($thing) = @_;
 175
 176   # Remember that when ->check is called inside coerce, a return value of 0
 177   # means that coercion should take place, while 1 signifies that the value is
 178   # already OK. Thus we should return true if and only if $thing passes the
 179   # target type constraint.
 180
 181   return $target->check($thing);
 182  });
 183
 184  return $class->$orig(%args);
 185 };
 186
 187 =head2 C<coerce $thing>
 188
 189 Tries to coerce C<$thing> by first loading a class that might contain a type coercion for it.
 190
 191 =cut
 192
 193 around 'coerce' => sub {
 194  my ($orig, $tc, $thing) = @_;
 195
 196  # The original coerce gets an hold onto the type coercions *before* calling
 197  # the constraint. Thus, we have to force the loading before recalling into
 198  # $orig.
 199
 200  # First, check whether $thing is already of the right kind.
 201  return $thing if $tc->check($thing);
 202
 203  # If $thing isn't even an object, don't bother trying to autoload a coercion
 204  my $class = blessed($thing);
 205  if (defined $class) {
 206   $class = $tc->mapper->($tc, $class);
 207
 208   if (defined $class) {
 209    # Find the file to autoload
 210    (my $pm = $class) =~ s{::}{/}g;
 211    $pm .= '.pm';
 212
 213    unless ($INC{$pm}) { # Not loaded yet
 214     local $@;
 215     eval {
 216      # We die often here, even though we're not really interested in the error.
 217      # However, if a die handler is set (e.g. to \&Carp::confess), this can get
 218      # very slow. Resetting the handler shows a 10% total time improvement for
 219      # the geodyn app.
 220      local $SIG{__DIE__};
 221      require $pm;
 222     };
 223    }
 224   }
 225  }
 226
 227  $tc->$orig($thing);
 228 };
 229
 230 __PACKAGE__->meta->make_immutable(
 231  inline_constructor => 0,
 232 );
 233
 234 =head1 SEE ALSO
 235
 236 L<Moose::Meta::TypeConstraint>, L<Mouse::Meta::TypeConstraint>.
 237
 238 =head1 AUTHOR
 239
 240 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 241
 242 You can contact me by mail or on C<irc.perl.org> (vincent).
 243
 244 =head1 BUGS
 245
 246 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>.
 247 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 248
 249 =head1 SUPPORT
 250
 251 You can find documentation for this module with the perldoc command.
 252
 253     perldoc LaTeX::TikZ
 254
 255 =head1 COPYRIGHT & LICENSE
 256
 257 Copyright 2010 Vincent Pit, all rights reserved.
 258
 259 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 260
 261 =cut
 262
 263 1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce