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