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;
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 {
}
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
$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;
}
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,
);
}
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 {
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){
return 1;
};
}
+ return;
}
1;
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,
);
}
. "$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'){
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 (@{$_}) {
};
$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 %{$_}){
# '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->($_);
$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',
);
};
}
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;
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';
projects / gitmo/Mouse.git / commitdiff