X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint.pm;h=303b8fb4af5c4668d2beffbf686049955b33529d;hb=297899d15cdf00745649d439545a1e7daeac28b8;hp=e8f794331cd227b36a13e018ad3f07143bdbd7a2;hpb=9e4ed568f2e5c1041e6fea8d0cbde420562ab5df;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index e8f7943..303b8fb 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -5,18 +5,18 @@ use strict; use warnings; use metaclass; -use overload '""' => sub { shift->name }, # stringify to tc name +use overload '0+' => sub { refaddr(shift) }, # id an object + '""' => sub { shift->name }, # stringify to tc name + bool => sub { 1 }, fallback => 1; +use Eval::Closure; use Scalar::Util qw(blessed refaddr); use Sub::Name qw(subname); +use Try::Tiny; use base qw(Class::MOP::Object); -our $VERSION = '0.84'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - __PACKAGE__->meta->add_attribute('name' => (reader => 'name')); __PACKAGE__->meta->add_attribute('parent' => ( reader => 'parent', @@ -44,6 +44,18 @@ __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => ( predicate => 'has_hand_optimized_type_constraint', )); +__PACKAGE__->meta->add_attribute('inlined' => ( + init_arg => 'inlined', + accessor => 'inlined', + predicate => '_has_inlined_type_constraint', +)); + +__PACKAGE__->meta->add_attribute('inline_environment' => ( + init_arg => 'inline_environment', + accessor => '_inline_environment', + default => sub { {} }, +)); + sub parents { my $self; $self->parent; @@ -88,6 +100,25 @@ sub coerce { return $coercion->coerce(@_); } +sub assert_coerce { + my $self = shift; + + my $coercion = $self->coercion; + + unless ($coercion) { + require Moose; + Moose->throw_error("Cannot coerce without a type coercion"); + } + + return $_[0] if $self->check($_[0]); + + my $result = $coercion->coerce(@_); + + $self->assert_valid($result); + + return $result; +} + sub check { my ($self, @args) = @_; my $constraint_subref = $self->_compiled_type_constraint; @@ -104,6 +135,51 @@ sub validate { } } +sub can_be_inlined { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->can_be_inlined; + } + + return $self->_has_inlined_type_constraint; +} + +sub _inline_check { + my $self = shift; + + unless ( $self->can_be_inlined ) { + require Moose; + Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name ); + } + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->_inline_check(@_); + } + + return '( do { ' . $self->inlined->( $self, @_ ) . ' } )'; +} + +sub inline_environment { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->inline_environment; + } + + return $self->_inline_environment; +} + +sub assert_valid { + my ($self, $value) = @_; + + my $error = $self->validate($value); + return 1 if ! defined $error; + + require Moose; + Moose->throw_error($error); +} + sub get_message { my ($self, $value) = @_; if (my $msg = $self->message) { @@ -111,8 +187,19 @@ sub get_message { return $msg->($value); } else { - $value = (defined $value ? overload::StrVal($value) : 'undef'); - return "Validation failed for '" . $self->name . "' failed with value $value"; + # have to load it late like this, since it uses Moose itself + my $can_partialdump = try { + # versions prior to 0.14 had a potential infinite loop bug + Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 }); + 1; + }; + if ($can_partialdump) { + $value = Devel::PartialDump->new->dump($value); + } + else { + $value = (defined $value ? overload::StrVal($value) : 'undef'); + } + return "Validation failed for '" . $self->name . "' with value $value"; } } @@ -123,7 +210,7 @@ sub equals { my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; - return 1 if refaddr($self) == refaddr($other); + return 1 if $self == $other; if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) { return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint; @@ -138,7 +225,7 @@ sub equals { return if $other->has_parent; } - return 1; + return; } sub is_a_type_of { @@ -179,6 +266,13 @@ sub _actually_compile_type_constraint { return $self->_compile_hand_optimized_type_constraint if $self->has_hand_optimized_type_constraint; + if ( $self->can_be_inlined ) { + return eval_closure( + source => 'sub { ' . $self->_inline_check('$_[0]') . ' }', + environment => $self->inline_environment, + ); + } + my $check = $self->constraint; unless ( defined $check ) { require Moose; @@ -200,7 +294,6 @@ sub _compile_hand_optimized_type_constraint { unless ( ref $type_constraint ) { require Moose; - Carp::confess ("Hand optimized type constraint for " . $self->name . " is not a code reference"); Moose->throw_error("Hand optimized type constraint is not a code reference"); } @@ -290,18 +383,16 @@ sub create_child_type { 1; +# ABSTRACT: The Moose Type Constraint metaclass + __END__ =pod -=head1 NAME - -Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass - =head1 DESCRIPTION This class represents a single type constraint. Moose's built-in type -constraints, as well as constraints you define, are all store in a +constraints, as well as constraints you define, are all stored in a L object as objects of this class. @@ -344,8 +435,24 @@ the constraint fails. This is optional. A L object representing the coercions to the type. This is optional. +=item * inlined + +A subroutine which returns a string suitable for inlining this type +constraint. It will be called as a method on the type constraint object, and +will receive a single additional parameter, a variable name to be tested +(usually C<"$_"> or C<"$_[0]">. + +This is optional. + +=item * inline_environment + +A hash reference of variables to close over. The keys are variables names, and +the values are I to the variables. + =item * optimized +B + This is a variant of the C parameter that is somehow optimized. Typically, this means incorporating both the type's constraint and all of its parents' constraints into a single @@ -371,9 +478,17 @@ C and C. =item B<< $constraint->coerce($value) >> -This will attempt to coerce the value to the type. If the type does +This will attempt to coerce the value to the type. If the type does not have any defined coercions this will throw an error. +If no coercion can produce a value matching C<$constraint>, the original +value is returned. + +=item B<< $constraint->assert_coerce($value) >> + +This method behaves just like C, but if the result is not valid +according to C<$constraint>, an error is thrown. + =item B<< $constraint->check($value) >> Returns true if the given value passes the constraint for the type. @@ -385,6 +500,13 @@ method returns an explicit C. If the type is not valid, we call C<< $self->get_message($value) >> internally to generate an error message. +=item B<< $constraint->assert_valid($value) >> + +Like C and C, this method checks whether C<$value> is +valid under the constraint. If it is, it will return true. If it is not, +an exception will be thrown with the results of +C<< $self->get_message($value) >>. + =item B<< $constraint->name >> Returns the type's name, as provided to the constructor. @@ -428,13 +550,23 @@ exists. Returns true if the type has a coercion. +=item B<< $constraint->can_be_inlined >> + +Returns true if this type constraint can be inlined. A type constraint which +subtypes an inlinable constraint and does not add an additional constraint +"inherits" its parent type's inlining. + =item B<< $constraint->hand_optimized_type_constraint >> +B + Returns the type's hand optimized constraint, as provided to the constructor via the C option. =item B<< $constraint->has_hand_optimized_type_constraint >> +B + Returns true if the type has an optimized constraint. =item B<< $constraint->create_child_type(%options) >> @@ -449,21 +581,6 @@ behavior and change how child types are created. =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. - -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut