=head1 VERSION
-Version 0.01
+Version 0.02
=cut
-our $VERSION = '0.01';
+our $VERSION = '0.02';
+
+=head1 SYNOPSIS
+
+ # The target class of the autocoercion (cannot be changed)
+ {
+ package X;
+ use Mouse;
+ has 'id' => (
+ is => 'ro',
+ isa => 'Int',
+ );
+ use LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
+ use Mouse::Util::TypeConstraints;
+ register_type_constraint(
+ LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
+ name => 'X::Autocoerce',
+ target => find_type_constraint(__PACKAGE__),
+ mapper => sub { join '::', __PACKAGE__, 'From', $_[1] },
+ );
+ );
+ __PACKAGE__->meta->make_immutable;
+ }
+
+ # The class that does the coercion (cannot be changed)
+ {
+ package Y;
+ use Mouse;
+ has 'x' => (
+ is => 'ro',
+ isa => 'X::Autocoerce',
+ coerce => 1,
+ handles => [ 'id' ],
+ );
+ __PACKAGE__->meta->make_immutable;
+ }
+
+ # Another class the user wants to use instead of X (cannot be changed)
+ {
+ package Z;
+ use Mouse;
+ has 'id' => (
+ is => 'ro',
+ isa => 'Num',
+ );
+ __PACKAGE__->meta->make_immutable;
+ }
+
+ # The autocoercion class, defined by the user in X/From/Z.pm
+ {
+ package X::From::Z;
+ use Mouse::Util::TypeConstraints;
+ coerce 'X::Autocoerce'
+ => from 'Z'
+ => via { X->new(id => int $_->id) };
+ }
+
+ my $z = Z->new(id => 123);
+ my $y = Y->new(x => $z);
+ print $y->id; # 123
+
+=head1 DESCRIPTION
+
+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.
+This allows you to declare types that can be replaced (through coercion) at the end user's discretion.
+
+It only supports L<Mouse> currently.
+
+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>.
-use Scalar::Util qw/blessed/;
+=cut
+
+use Scalar::Util qw<blessed>;
use Sub::Name ();
-use Any::Moose;
-use Any::Moose 'Util' => [ 'find_meta' ];
+use LaTeX::TikZ::Tools;
-extends any_moose('Meta::TypeConstraint');
+use Mouse;
-=head1 ATTRIBUTES
+=head1 RELATIONSHIPS
-=head2 C<mapper>
+This class inherits from L<Mouse::Meta::TypeConstraint>.
=cut
-has 'mapper' => (
- is => 'ro',
- isa => 'CodeRef',
-);
+extends 'Mouse::Meta::TypeConstraint';
+
+=head1 ATTRIBUTES
+
+=head2 C<name>
-=head2 C<parent>
+The name of the type constraint.
+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.
+
+This attribute is inherited from the L<Mouse> type constraint metaclass.
+
+=head2 C<mapper>
+
+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.
+It is called with the type constraint object as first argument, followed by the class name.
=cut
-has 'parent' => (
+has 'mapper' => (
is => 'ro',
- isa => any_moose('Meta::TypeConstraint'),
+ isa => 'CodeRef',
required => 1,
);
-=head2 C<user_constraint>
+=head2 C<target>
+
+A type constraint that defines into what the objects are going to be coerced.
+Objects satisfying this type constraint will be automatically considered as valid and will not be coerced.
+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.
=cut
-has 'user_constraint' => (
+has 'target' => (
is => 'ro',
- isa => 'Maybe[CodeRef]',
+ isa => 'Mouse::Meta::TypeConstraint',
required => 1,
);
+my $target_tc = __PACKAGE__->meta->find_attribute_by_name('target')
+ ->type_constraint;
+
=head1 METHODS
+=head2 C<new>
+
+ my $tc = LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
+ name => $name,
+ mapper => $mapper,
+ target => $target,
+ );
+
+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>.
+
=cut
around 'new' => sub {
my ($orig, $class, %args) = @_;
unless (exists $args{mapper}) {
- $args{mapper} = sub { join '::', $_[0]->parent->name, $_[1] };
+ $args{mapper} = sub { join '::', $_[0]->target->name, $_[1] };
}
- my $parent = delete $args{parent};
- unless (blessed $parent) {
- $parent = find_meta($parent)->type_constraint;
+ my $target = delete $args{target};
+ unless (blessed $target) {
+ my $target_name = defined $target ? "target $target" : 'undefined target';
+ $target = LaTeX::TikZ::Tools::type_constraint($target) if defined $target;
+ Carp::confess("No meta object for $target_name") unless defined $target;
}
- __PACKAGE__->meta->find_attribute_by_name('parent')
- ->type_constraint->assert_valid($parent);
- $args{parent} = $parent;
+ $target_tc->assert_valid($target);
+ $args{target} = $target;
- $args{user_constraint} = delete $args{constraint};
+ $args{constraint} = Sub::Name::subname('_constraint' => sub {
+ my ($thing) = @_;
- if (any_moose() eq 'Moose') {
- $args{coercion} = Moose::Meta::TypeCoercion->new;
- }
+ # Remember that when ->check is called inside coerce, a return value of 0
+ # means that coercion should take place, while 1 signifies that the value is
+ # already OK. Thus we should return true if and only if $thing passes the
+ # target type constraint.
- my $tc;
- $args{constraint} = Sub::Name::subname('_load' => sub {
- $tc->load(@_);
+ return $target->check($thing);
});
- $tc = $class->$orig(%args);
+ return $class->$orig(%args);
};
-=head2 C<load>
-
-=cut
-
-sub load {
- my ($tc, $thing) = @_;
-
- # When ->check is called inside coerce, a return value of 0 means that
- # coercion should take place, while 1 signifies that the value is already
- # OK.
-
- # First, try a possible user defined constraint
- my $user = $tc->user_constraint;
- if (defined $user) {
- my $ok = $user->($thing);
- return 1 if $ok;
- }
-
- # Then, try the parent constraint
- return 1 if $tc->parent->check($thing);
+=head2 C<coerce>
- # If $thing isn't even an object, don't bother trying to coerce it
- my $class = blessed($thing);
- return 0 unless defined $class;
-
- # Find the file to autoload
- my $mapper = $tc->mapper;
- my $pm = $class = $tc->$mapper($class);
- $pm =~ s{::}{/}g;
- $pm .= '.pm';
- return 0 if $INC{$pm}; # already loaded
+ $tc->coerce($thing)
- local $@;
- eval { require $pm; 1 };
+Tries to coerce C<$thing> by first loading a class that might contain a type coercion for it.
- return 0;
-}
+=cut
around 'coerce' => sub {
my ($orig, $tc, $thing) = @_;
# The original coerce gets an hold onto the type coercions *before* calling
# the constraint. Thus, we have to force the loading before recalling into
- # $orig. This is achieved by calling ->load.
- return $thing if $tc->load($thing);
+ # $orig.
+
+ # First, check whether $thing is already of the right kind.
+ return $thing if $tc->check($thing);
+
+ # If $thing isn't even an object, don't bother trying to autoload a coercion
+ my $class = blessed($thing);
+ if (defined $class) {
+ $class = $tc->mapper->($tc, $class);
+
+ if (defined $class) {
+ # Find the file to autoload
+ (my $pm = $class) =~ s{::}{/}g;
+ $pm .= '.pm';
+
+ unless ($INC{$pm}) { # Not loaded yet
+ local $@;
+ eval {
+ # We die often here, even though we're not really interested in the error.
+ # However, if a die handler is set (e.g. to \&Carp::confess), this can get
+ # very slow. Resetting the handler shows a 10% total time improvement for
+ # the geodyn app.
+ local $SIG{__DIE__};
+ require $pm;
+ };
+ }
+ }
+ }
$tc->$orig($thing);
};
inline_constructor => 0,
);
+=head1 SEE ALSO
+
+L<Mouse::Meta::TypeConstraint>.
+
=head1 AUTHOR
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
=head1 COPYRIGHT & LICENSE
-Copyright 2010 Vincent Pit, all rights reserved.
+Copyright 2010,2011,2012,2013,2014,2015 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
projects / perl / modules / LaTeX-TikZ.git / blobdiff