X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FTypeConstraint.pm;h=f4506db7cfb58d1e8a8450ba1c7eabbaa83c281a;hp=51b08670f70e0338af416f735163696202903528;hb=536e3c3344d408e94ee34d3d7d4d63e485ee8aec;hpb=37dc67cb9daf91c9530e5ffc762de36cb0432c7f diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm index 51b0867..f4506db 100644 --- a/lib/Mouse/Meta/TypeConstraint.pm +++ b/lib/Mouse/Meta/TypeConstraint.pm @@ -1,57 +1,164 @@ package Mouse::Meta::TypeConstraint; -use strict; -use warnings; -use Carp (); +use Mouse::Util qw(:meta); # enables strict and warnings -use overload '""' => sub { shift->{name} }, # stringify to tc name - fallback => 1; +use overload + 'bool' => sub { 1 }, # always true + + '""' => sub { $_[0]->name }, # stringify to tc name + + '|' => sub { # or-combination + require Mouse::Util::TypeConstraints; + return Mouse::Util::TypeConstraints::find_or_parse_type_constraint( + "$_[0] | $_[1]", + ); + }, + + fallback => 1; + +use Carp (); sub new { - my $class = shift; - my %args = @_; - my $name = $args{name} || '__ANON__'; + my($class, %args) = @_; + + $args{name} = '__ANON__' if !defined $args{name}; + + my $check = delete $args{optimized}; + + if($check){ + $args{hand_optimized_type_constraint} = $check; + $args{compiled_type_constraint} = $check; + } - my $check = $args{_compiled_type_constraint} or Carp::croak("missing _compiled_type_constraint"); - if (ref $check eq 'Mouse::Meta::TypeConstraint') { - $check = $check->{_compiled_type_constraint}; + $check = $args{constraint}; + + if(defined($check) && ref($check) ne 'CODE'){ + Carp::confess("Constraint for $args{name} is not a CODE reference"); } - bless +{ - name => $name, - _compiled_type_constraint => $check, - message => $args{message} - }, $class; + $args{package_defined_in} ||= caller; + + my $self = bless \%args, $class; + $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint}; + + $self->_compile_union_type_coercion() if $self->{type_constraints}; + return $self; } -sub name { shift->{name} } +sub create_child_type{ + my $self = shift; + # XXX: FIXME + return ref($self)->new( + # a child inherits its parent's attributes + %{$self}, + + # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint' + compiled_type_constraint => undef, + hand_optimized_type_constraint => undef, -sub check { + # and is given child-specific args, of course. + @_, + + # and its parent + parent => $self, + ); +} + +sub name; +sub parent; +sub message; +sub has_coercion; +sub _compiled_type_constraint; +sub _compiled_type_coercion; + +sub compile_type_constraint; + +sub _add_type_coercions{ my $self = shift; - $self->{_compiled_type_constraint}->(@_); + + my $coercions = ($self->{_coercion_map} ||= []); + my %has = map{ $_->[0] => undef } @{$coercions}; + + for(my $i = 0; $i < @_; $i++){ + my $from = $_[ $i]; + my $action = $_[++$i]; + + if(exists $has{$from}){ + Carp::confess("A coercion action already exists for '$from'"); + } + + my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from) + or Carp::confess("Could not find the type constraint ($from) to coerce from"); + + push @{$coercions}, [ $type => $action ]; + } + + # compile + if(exists $self->{type_constraints}){ # union type + Carp::confess("Cannot add additional type coercions to Union types"); + } + else{ + $self->_compile_type_coercion(); + } + return; } -sub validate { - my ($self, $value) = @_; - if ($self->{_compiled_type_constraint}->($value)) { - return undef; - } - else { - $self->get_message($value); - } +sub _compile_type_coercion { + my($self) = @_; + + my @coercions = @{$self->{_coercion_map}}; + + $self->{_compiled_type_coercion} = sub { + my($thing) = @_; + foreach my $pair (@coercions) { + #my ($constraint, $converter) = @$pair; + if ($pair->[0]->check($thing)) { + local $_ = $thing; + return $pair->[1]->($thing); + } + } + return $thing; + }; + return; } -sub assert_valid { - my ($self, $value) = @_; - - my $error = $self->validate($value); - return 1 if ! defined $error; +sub _compile_union_type_coercion { + my($self) = @_; - Carp::confess($error); -} + my @coercions; + foreach my $type(@{$self->{type_constraints}}){ + if($type->has_coercion){ + push @coercions, $type; + } + } + if(@coercions){ + $self->{_compiled_type_coercion} = sub { + my($thing) = @_; + foreach my $type(@coercions){ + my $value = $type->coerce($thing); + return $value if $self->check($value); + } + return $thing; + }; + } + return; +} + +sub check { + my $self = shift; + return $self->_compiled_type_constraint->(@_); +} + +sub coerce { + my $self = shift; + + my $coercion = $self->_compiled_type_coercion; + if(!$coercion){ + Carp::confess("Cannot coerce without a type coercion"); + } + return $_[0] if $self->_compiled_type_constraint->(@_); -sub message { - return $_[0]->{message}; + return $coercion->(@_); } sub get_message { @@ -62,19 +169,67 @@ sub get_message { } else { $value = ( defined $value ? overload::StrVal($value) : 'undef' ); - return - "Validation failed for '" - . $self->name - . "' failed with value $value"; + return "Validation failed for '$self' failed with value $value"; } } +sub is_a_type_of{ + my($self, $other) = @_; + + # ->is_a_type_of('__ANON__') is always false + return 0 if !ref($other) && $other eq '__ANON__'; + + (my $other_name = $other) =~ s/\s+//g; + + return 1 if $self->name eq $other_name; + + if(exists $self->{type_constraints}){ # union + foreach my $type(@{$self->{type_constraints}}){ + return 1 if $type->name eq $other_name; + } + } + + for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){ + return 1 if $parent->name eq $other_name; + } + + return 0; +} + +# See also Moose::Meta::TypeConstraint::Parameterizable +sub parameterize{ + my($self, $param, $name) = @_; + + if(!ref $param){ + require Mouse::Util::TypeConstraints; + $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param); + } + + $name ||= sprintf '%s[%s]', $self->name, $param->name; + + my $generator = $self->{constraint_generator} + || Carp::confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type"); + + return Mouse::Meta::TypeConstraint->new( + name => $name, + parent => $self, + parameter => $param, + constraint => $generator->($param), # must be 'constraint', not 'optimized' + + type => 'Parameterized', + ); +} + 1; __END__ =head1 NAME -Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass +Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass + +=head1 VERSION + +This document describes Mouse version 0.50 =head1 DESCRIPTION @@ -96,5 +251,9 @@ Don't use this. =back +=head1 SEE ALSO + +L + =cut