X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint.pm;h=64b266d7567541efa0d1e3cca8b280324758c366;hb=c9d7e3969b1695246e82f8d4260222216d2aa722;hp=876d80c786f455c4b6dc331f79796a19f8fb7581;hpb=cfd006f0b8626746aedb71e4fe8fb7de21ec5497;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 876d80c..64b266d 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -9,10 +9,11 @@ use overload '""' => sub { shift->name }, # stringify to tc name fallback => 1; use Scalar::Util qw(blessed refaddr); +use Sub::Name qw(subname); use base qw(Class::MOP::Object); -our $VERSION = '0.72'; +our $VERSION = '0.79'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -82,6 +83,8 @@ sub coerce { Moose->throw_error("Cannot coerce without a type coercion"); } + return $_[0] if $self->check($_[0]); + return $coercion->coerce(@_); } @@ -108,9 +111,9 @@ sub get_message { return $msg->($value); } else { - $value = (defined $value ? overload::StrVal($value) : 'undef'); + $value = (defined $value ? overload::StrVal($value) : 'undef'); return "Validation failed for '" . $self->name . "' failed with value $value"; - } + } } ## type predicates ... @@ -232,7 +235,7 @@ sub _compile_subtype { if ( $check == $null_constraint ) { return $optimized_parent; } else { - return Class::MOP::subname($self->name, sub { + return subname($self->name, sub { return undef unless $optimized_parent->($_[0]); my (@args) = @_; local $_ = $args[0]; @@ -243,7 +246,7 @@ sub _compile_subtype { # general case, check all the constraints, from the first parent to ourselves my @checks = @parents; push @checks, $check if $check != $null_constraint; - return Class::MOP::subname($self->name => sub { + return subname($self->name => sub { my (@args) = @_; local $_ = $args[0]; foreach my $check (@checks) { @@ -259,7 +262,7 @@ sub _compile_type { return $check if $check == $null_constraint; # Item, Any - return Class::MOP::subname($self->name => sub { + return subname($self->name => sub { my (@args) = @_; local $_ = $args[0]; $check->(@args); @@ -285,10 +288,6 @@ sub create_child_type { return $class->new(%opts, parent => $self); } -## this should get deprecated actually ... - -sub union { Carp::croak "DEPRECATED" } - 1; __END__ @@ -306,6 +305,10 @@ constraints, as well as constraints you define, are all store in a L object as objects of this class. +=head1 INHERITANCE + +C is a subclass of L. + =head1 METHODS =over 4