From: gfx Date: Wed, 30 Sep 2009 05:58:42 +0000 (+0900) Subject: Refactor type constraints X-Git-Tag: 0.37_01~25 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3b89ea918d7ff7162f2bbeecf24df818148d5315;p=gitmo%2FMouse.git Refactor type constraints --- diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm index 4d7e3a9..db3903c 100755 --- a/lib/Mouse/Meta/Method/Accessor.pm +++ b/lib/Mouse/Meta/Method/Accessor.pm @@ -15,7 +15,7 @@ sub _install_accessor{ my $should_deref = $attribute->should_auto_deref; my $should_coerce = $attribute->should_coerce; - my $compiled_type_constraint = $constraint ? $constraint->{_compiled_type_constraint} : undef; + my $compiled_type_constraint = $constraint ? $constraint->_compiled_type_constraint : undef; my $self = '$_[0]'; my $key = sprintf q{"%s"}, quotemeta $name; diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index 596dccf..1dd8b3a 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -12,7 +12,8 @@ sub generate_constructor_method_inline { my $buildargs = $class->_generate_BUILDARGS($metaclass); my $processattrs = $class->_generate_processattrs($metaclass, \@attrs); - my @compiled_constraints = map { $_ ? $_->{_compiled_type_constraint} : undef } map { $_->{type_constraint} } @attrs; + my @compiled_constraints = map { $_->_compiled_type_constraint } + map { $_->{type_constraint} ? $_->{type_constraint} : () } @attrs; my $code = <<"..."; sub { @@ -57,11 +58,7 @@ sub _generate_processattrs { } if ($attr->has_type_constraint) { - if ($attr->type_constraint->{_compiled_type_constraint}) { - $code .= "unless (\$compiled_constraints[$index](\$value)) {"; - } else { - $code .= "unless (\$attrs[$index]->{type_constraint}->check(\$value)) {"; - } + $code .= "unless (\$compiled_constraints[$index](\$value)) {"; $code .= " \$attrs[$index]->verify_type_constraint_error( q{$key}, \$value, \$attrs[$index]->type_constraint diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm index caeb980..2588174 100644 --- a/lib/Mouse/Meta/TypeConstraint.pm +++ b/lib/Mouse/Meta/TypeConstraint.pm @@ -18,19 +18,38 @@ sub new { $args{name} = '__ANON__' if !defined $args{name}; - my $check = $args{_compiled_type_constraint} || $args{constraint}; + my $check = delete $args{optimized}; + + if($args{_compiled_type_constraint}){ + Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead"); + $check = $args{_compiled_type_constraint}; + + if(blessed($check)){ + Carp::cluck("Constraint must be a CODE reference"); + $check = $check->{compiled_type_constraint}; + } + } + + if($check){ + $args{hand_optimized_type_constraint} = $check; + $args{compiled_type_constraint} = $check; + } + + $check = $args{constraint}; if(blessed($check)){ - Carp::cluck("'constraint' must be a CODE reference"); - $check = $check->{_compiled_type_constraint}; + Carp::cluck("Constraint for $args{name} must be a CODE reference"); + $check = $check->{compiled_type_constraint}; } if(defined($check) && ref($check) ne 'CODE'){ - confess("Type constraint for $args{name} is not a CODE reference"); + confess("Constraint for $args{name} is not a CODE reference"); } + $args{package_defined_in} ||= caller; + my $self = bless \%args, $class; - $self->{_compiled_type_constraint} ||= $self->_compile(); + $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint}; return $self; } @@ -39,10 +58,18 @@ sub create_child_type{ my $self = shift; # XXX: FIXME return ref($self)->new( - %{$self}, # pass the inherit parent attributes - _compiled_type_constraint => undef, # ... other than compiled type constraint - @_, # ... and args - parent => $self # ... and the parent + # 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, + + # and is given child-specific args, of course. + @_, + + # and its parent + parent => $self, ); } @@ -50,14 +77,16 @@ sub name { $_[0]->{name} } sub parent { $_[0]->{parent} } sub message { $_[0]->{message} } +sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} } + sub check { my $self = shift; - $self->{_compiled_type_constraint}->(@_); + $self->_compiled_type_constraint->(@_); } sub validate { my ($self, $value) = @_; - if ($self->{_compiled_type_constraint}->($value)) { + if ($self->_compiled_type_constraint->($value)) { return undef; } else { @@ -112,39 +141,49 @@ sub is_a_type_of{ return 0; } -sub _compile{ +sub compile_type_constraint{ my($self) = @_; # add parents first my @checks; for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){ - if($parent->{constraint}){ + if($parent->{hand_optimized_type_constraint}){ + push @checks, $parent->{hand_optimized_type_constraint}; + last; # a hand optimized constraint must include all the parents + } + elsif($parent->{constraint}){ push @checks, $parent->{constraint}; - } - elsif($parent->{_compiled_type_constraint} && $parent->{_compiled_type_constraint} != $null_check){ - # hand-optimized constraint - push @checks, $parent->{_compiled_type_constraint}; - last; } } + # then add child if($self->{constraint}){ push @checks, $self->{constraint}; } + if($self->{type_constraints}){ # Union + my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} }; + push @checks, sub{ + foreach my $c(@types){ + return 1 if $c->($_[0]); + } + return 0; + }; + } + if(@checks == 0){ - return $null_check; + $self->{compiled_type_constraint} = $null_check; } elsif(@checks == 1){ my $c = $checks[0]; - return sub{ + $self->{compiled_type_constraint} = sub{ my(@args) = @_; local $_ = $args[0]; return $c->(@args); }; } else{ - return sub{ + $self->{compiled_type_constraint} = sub{ my(@args) = @_; local $_ = $args[0]; foreach my $c(@checks){ @@ -153,6 +192,7 @@ sub _compile{ return 1; }; } + return; } 1; diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index e08a67f..6d8ccfa 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -72,9 +72,8 @@ BEGIN { while (my ($name, $code) = each %builtins) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( - name => $name, - _compiled_type_constraint => $code, - package_defined_in => __PACKAGE__, + name => $name, + optimized => $code, ); } @@ -125,10 +124,8 @@ sub _create_type{ . "$existing->{package_defined_in} and cannot be created again in $package_defined_in"); } - $args{constraint} = delete($args{where}) - if exists $args{where}; - $args{_compiled_type_constraint} = delete $args{optimized_as} - if exists $args{optimized_as}; + $args{constraint} = delete($args{where}) if exists $args{where}; + $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as}; my $constraint; if($mode eq 'subtype'){ @@ -297,16 +294,16 @@ sub _find_or_create_regular_type{ warn "#CREATE a $type type for $spec\n" if _DEBUG; return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( - name => $spec, - _compiled_type_constraint => $check, + name => $spec, + optimized => $check, - type => $type, + type => $type, ); } $TYPE{ArrayRef}{constraint_generator} = sub { my($type_parameter) = @_; - my $check = $type_parameter->{_compiled_type_constraint}; + my $check = $type_parameter->_compiled_type_constraint; return sub{ foreach my $value (@{$_}) { @@ -317,7 +314,7 @@ $TYPE{ArrayRef}{constraint_generator} = sub { }; $TYPE{HashRef}{constraint_generator} = sub { my($type_parameter) = @_; - my $check = $type_parameter->{_compiled_type_constraint}; + my $check = $type_parameter->_compiled_type_constraint; return sub{ foreach my $value(values %{$_}){ @@ -330,7 +327,7 @@ $TYPE{HashRef}{constraint_generator} = sub { # 'Maybe' type accepts 'Any', so it requires parameters $TYPE{Maybe}{constraint_generator} = sub { my($type_parameter) = @_; - my $check = $type_parameter->{_compiled_type_constraint}; + my $check = $type_parameter->_compiled_type_constraint; return sub{ return !defined($_) || $check->($_); @@ -368,20 +365,11 @@ sub _find_or_create_union_type{ $TYPE{$name} ||= do{ warn "# CREATE a Union type for ", Mouse::Util::english_list(@types),"\n" if _DEBUG; - my @checks = map{ $_->{_compiled_type_constraint} } @types; - my $check = sub{ - foreach my $c(@checks){ - return 1 if $c->($_[0]); - } - return 0; - }; - return Mouse::Meta::TypeConstraint->new( - name => $name, - _compiled_type_constraint => $check, - type_constraints => \@types, + name => $name, + type_constraints => \@types, - type => 'Union', + type => 'Union', ); }; } @@ -416,13 +404,9 @@ sub _parse_type{ elsif($char eq '|'){ my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) ); - # XXX: Currently Mouse create an anonymous type for backward compatibility if(!defined $type){ - my $class = substr($spec, $start, $i - $start); - $type = Mouse::Meta::TypeConstraint->new( - name => $class, - _compiled_type_constraint => sub{ blessed($_[0]) && $_[0]->isa($class) }, - ); + # XXX: Mouse creates a new class type, but Moose does not. + $type = class_type( substr($spec, $start, $i - $start) ); } push @list, $type; diff --git a/t/lib/Test/Mouse.pm b/t/lib/Test/Mouse.pm index 8d219dd..80e754f 100644 --- a/t/lib/Test/Mouse.pm +++ b/t/lib/Test/Mouse.pm @@ -63,7 +63,7 @@ sub export_type_constraints_as_functions { # TEST ONLY my $into = caller; foreach my $type( list_all_type_constraints() ) { - my $tc = find_type_constraint($type)->{_compiled_type_constraint}; + my $tc = find_type_constraint($type)->_compiled_type_constraint; my $as = $into . '::' . $type; no strict 'refs';