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 Mouse;
  24      has 'id' => (
  25       is  => 'ro',
  26       isa => 'Int',
  27      );
  28      use LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
  29      use Mouse::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 Mouse;
  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 Mouse;
  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 Mouse::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 only supports L<Mouse> currently.
  83
  84 Note that you will need L<Mouse::Util::TypeConstraints/register_type_constraint> to install this type constraint, which 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 Mouse;
  95
  96 =head1 RELATIONSHIPS
  97
  98 This class inherits from L<Mouse::Meta::TypeConstraint>.
  99
 100 =cut
 101
 102 extends 'Mouse::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<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<target>
 127
 128 A type constraint that defines into what the objects are going to be coerced.
 129 Objects satisfying this type constraint will be automatically considered as valid and will not be coerced.
 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 'target' => (
 135  is       => 'ro',
 136  isa      => 'Mouse::Meta::TypeConstraint',
 137  required => 1,
 138 );
 139
 140 my $target_tc = __PACKAGE__->meta->find_attribute_by_name('target')
 141                                  ->type_constraint;
 142
 143 =head1 METHODS
 144
 145 =head2 C<new>
 146
 147     my $tc = LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
 148      name   => $name,
 149      mapper => $mapper,
 150      target => $target,
 151     );
 152
 153 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>.
 154
 155 =cut
 156
 157 around 'new' => sub {
 158  my ($orig, $class, %args) = @_;
 159
 160  unless (exists $args{mapper}) {
 161   $args{mapper} = sub { join '::', $_[0]->target->name, $_[1] };
 162  }
 163
 164  my $target = delete $args{target};
 165  unless (blessed $target) {
 166   my $target_name = defined $target ? "target $target" : 'undefined target';
 167   $target = LaTeX::TikZ::Tools::type_constraint($target) if defined $target;
 168   Carp::confess("No meta object for $target_name")   unless defined $target;
 169  }
 170  $target_tc->assert_valid($target);
 171  $args{target} = $target;
 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>
 188
 189     $tc->coerce($thing)
 190
 191 Tries to coerce C<$thing> by first loading a class that might contain a type coercion for it.
 192
 193 =cut
 194
 195 around 'coerce' => sub {
 196  my ($orig, $tc, $thing) = @_;
 197
 198  # The original coerce gets an hold onto the type coercions *before* calling
 199  # the constraint. Thus, we have to force the loading before recalling into
 200  # $orig.
 201
 202  # First, check whether $thing is already of the right kind.
 203  return $thing if $tc->check($thing);
 204
 205  # If $thing isn't even an object, don't bother trying to autoload a coercion
 206  my $class = blessed($thing);
 207  if (defined $class) {
 208   $class = $tc->mapper->($tc, $class);
 209
 210   if (defined $class) {
 211    # Find the file to autoload
 212    (my $pm = $class) =~ s{::}{/}g;
 213    $pm .= '.pm';
 214
 215    unless ($INC{$pm}) { # Not loaded yet
 216     local $@;
 217     eval {
 218      # We die often here, even though we're not really interested in the error.
 219      # However, if a die handler is set (e.g. to \&Carp::confess), this can get
 220      # very slow. Resetting the handler shows a 10% total time improvement for
 221      # the geodyn app.
 222      local $SIG{__DIE__};
 223      require $pm;
 224     };
 225    }
 226   }
 227  }
 228
 229  $tc->$orig($thing);
 230 };
 231
 232 __PACKAGE__->meta->make_immutable(
 233  inline_constructor => 0,
 234 );
 235
 236 =head1 SEE ALSO
 237
 238 L<Mouse::Meta::TypeConstraint>.
 239
 240 =head1 AUTHOR
 241
 242 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 243
 244 You can contact me by mail or on C<irc.perl.org> (vincent).
 245
 246 =head1 BUGS
 247
 248 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>.
 249 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 250
 251 =head1 SUPPORT
 252
 253 You can find documentation for this module with the perldoc command.
 254
 255     perldoc LaTeX::TikZ
 256
 257 =head1 COPYRIGHT & LICENSE
 258
 259 Copyright 2010,2011,2012,2013,2014,2015 Vincent Pit, all rights reserved.
 260
 261 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 262
 263 =cut
 264
 265 1; # End of LaTeX::TikZ::Meta::TypeConstraint::Autocoerce