X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FLaTeX%2FTikZ%2FMeta%2FTypeConstraint%2FAutocoerce.pm;h=28ca7067a1135f308f18d6234eb49bea2a0d7a92;hb=61a93a58351bf2d238dcf81a1a557112b0c0ee85;hp=9cc2322913697542f680313b7c9bba6aeba995dc;hpb=2ea319e77977b3651f90953e477e43e23244fcbd;p=perl%2Fmodules%2FLaTeX-TikZ.git diff --git a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm index 9cc2322..28ca706 100644 --- a/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm +++ b/lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm @@ -9,102 +9,222 @@ LaTeX::TikZ::Meta::TypeConstraint::Autocoerce - Type constraint metaclass that a =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 currently. + +Note that you will need L to install this type constraint, which is only available starting L C<0.63>. + +=cut + +use Scalar::Util qw; use Sub::Name (); -use Any::Moose; +use LaTeX::TikZ::Tools; -extends any_moose('Meta::TypeConstraint'); +use Mouse; -has 'mapper' => ( - is => 'ro', - isa => 'CodeRef', -); +=head1 RELATIONSHIPS + +This class inherits from L. + +=cut + +extends 'Mouse::Meta::TypeConstraint'; + +=head1 ATTRIBUTES + +=head2 C + +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. -has 'parent_name' => ( +This attribute is inherited from the L type constraint metaclass. + +=head2 C + +A code reference that maps an object class name to the name of the package in which the coercion can be found, or C 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 'mapper' => ( is => 'ro', - isa => 'ClassName', + isa => 'CodeRef', required => 1, ); -has 'user_constraint' => ( +=head2 C + +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 '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 + + 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}; - $args{parent_name} = defined $parent - ? (blessed($parent) ? $parent->name : $parent) - : '__ANON__'; - - $args{user_constraint} = $args{constraint}; - - if (any_moose() eq 'Moose') { - $args{coercion} = Moose::Meta::TypeCoercion->new; + 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; } + $target_tc->assert_valid($target); + $args{target} = $target; + + $args{constraint} = Sub::Name::subname('_constraint' => sub { + my ($thing) = @_; - my $parent_name = $args{parent_name}; - $parent_name =~ s/::+/_/g; + # 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); }; -sub load { - my ($tc, $thing) = @_; - - # First, try a possible user defined constraint - my $user = $tc->user_constraint; - if (defined $user) { - my $ok = $user->($thing); - return 1 if $ok; - } - - # 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. - - my $class = blessed($thing); - return 0 unless $class; - return 1 if $class->isa($tc->parent_name); - - my $mapper = $tc->mapper; - my $pm = $class = $tc->$mapper($class); +=head2 C - $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); }; @@ -113,6 +233,10 @@ __PACKAGE__->meta->make_immutable( inline_constructor => 0, ); +=head1 SEE ALSO + +L. + =head1 AUTHOR Vincent Pit, C<< >>, L. @@ -132,7 +256,7 @@ You can find documentation for this module with the perldoc command. =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.