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