From: Tokuhiro Matsuno Date: Wed, 11 Mar 2009 07:57:06 +0000 (+0900) Subject: added Mouse::Meta::TypeConstraint and use it. Mouse::Meta::Attribute->type_constraint... X-Git-Tag: 0.20~35 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=684db121da77d6c63be5a58e33606907ca2aa4fb added Mouse::Meta::TypeConstraint and use it. Mouse::Meta::Attribute->type_constraint returns an object. and, find_type_constraint was deprecated. --- diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index a6fcee4..4344c27 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -5,6 +5,7 @@ require overload; use Carp 'confess'; use Scalar::Util (); +use Mouse::Meta::TypeConstraint; sub new { my ($class, $name, %options) = @_; @@ -36,7 +37,6 @@ sub trigger { $_[0]->{trigger} } sub builder { $_[0]->{builder} } sub should_auto_deref { $_[0]->{auto_deref} } sub should_coerce { $_[0]->{should_coerce} } -sub find_type_constraint { $_[0]->{find_type_constraint} } sub has_default { exists $_[0]->{default} } sub has_predicate { exists $_[0]->{predicate} } @@ -63,7 +63,7 @@ sub generate_accessor { my $name = $attribute->name; my $default = $attribute->default; - my $constraint = $attribute->find_type_constraint; + my $constraint = $attribute->type_constraint; my $builder = $attribute->builder; my $trigger = $attribute->trigger; my $is_weak = $attribute->is_weak_ref; @@ -89,15 +89,15 @@ sub generate_accessor { $accessor .= "\n". '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . - 'Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{find_type_constraint}, $attribute->{type_constraint}, '.$value.');'; + 'Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{type_constraint}, '.$value.');'; } else { $accessor .= $value.';'; } $accessor .= "\n". '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . - 'unless ($constraint->($val)) { - $attribute->verify_type_constraint_error($name, $val, $attribute->type_constraint); + 'unless ($constraint->check($val)) { + $attribute->verify_type_constraint_error($name, $val, $attribute->{type_constraint}); }' . "\n"; $value = '$val'; } @@ -134,8 +134,8 @@ sub generate_accessor { } if ($should_deref) { - my $type_constraint = $attribute->type_constraint; - if (!ref($type_constraint) && $type_constraint eq 'ArrayRef') { + my $type_constraint = $attribute->{type_constraint}; + if (ref($type_constraint) && $type_constraint->name eq 'ArrayRef') { $accessor .= 'if (wantarray) { return @{ '.$self.'->{'.$key.'} || [] }; }'; @@ -220,13 +220,7 @@ sub create { ; my $type_constraint = delete $args{isa}; - $type_constraint =~ s/\s+//g; - my $code = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($type_constraint); - $args{type_constraint} = $type_constraint =~ /\|/ ? - [ split (/\|/, $type_constraint ) ] : - $type_constraint - ; - $args{find_type_constraint} = $code; + $args{type_constraint}= Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($type_constraint); } my $attribute = $self->new($name, %args); @@ -324,15 +318,15 @@ sub verify_against_type_constraint { return 1 unless $_[0]->{type_constraint}; local $_ = $_[1]; - return 1 if $_[0]->{find_type_constraint}->($_); + return 1 if $_[0]->{type_constraint}->check($_); my $self = shift; - $self->verify_type_constraint_error($self->name, $_, $self->type_constraint); + $self->verify_type_constraint_error($self->name, $_, $self->{type_constraint}); } sub verify_type_constraint_error { my($self, $name, $value, $type) = @_; - $type = ref($type) eq 'ARRAY' ? join '|', @{ $type } : $type; + $type = ref($type) eq 'ARRAY' ? join '|', map { $_->name } @{ $type } : $type->name; my $display = defined($value) ? overload::StrVal($value) : 'undef'; Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display"); } @@ -340,7 +334,7 @@ sub verify_type_constraint_error { sub coerce_constraint { ## my($self, $value) = @_; my $type = $_[0]->{type_constraint} or return $_[1]; - return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $_[0]->find_type_constraint, $type, $_[1]); + return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $_[0]->type_constraint, $_[1]); } sub _canonicalize_handles { @@ -462,11 +456,6 @@ Creates a new code reference for the attribute's clearer. Creates a new code reference for each of the attribute's handles methods. -=head2 find_type_constraint -> CODE - -Returns a code reference which can be used to check that a given value passes -this attribute's type constraint; - =head2 verify_against_type_constraint Item -> 1 | ERROR Checks that the given value passes this attribute's type constraint. Returns 1 diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index 4c22fd8..9c8d4f8 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -42,7 +42,7 @@ sub _generate_processattrs { $code .= "if (exists \$args->{'$from'}) {\n"; if ($attr->should_coerce && $attr->type_constraint) { - $code .= "my \$value = Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{find_type_constraint}, \$attrs[$index]->{type_constraint}, \$args->{'$from'});\n"; + $code .= "my \$value = Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{type_constraint}, \$attrs[$index]->{type_constraint}, \$args->{'$from'});\n"; } else { $code .= "my \$value = \$args->{'$from'};\n"; @@ -50,7 +50,7 @@ sub _generate_processattrs { if ($attr->has_type_constraint) { $code .= "{ - unless (\$attrs[$index]->{find_type_constraint}->(\$value)) { + unless (\$attrs[$index]->{type_constraint}->check(\$value)) { \$attrs[$index]->verify_type_constraint_error('$key', \$_, \$attrs[$index]->type_constraint) } }"; @@ -77,7 +77,7 @@ sub _generate_processattrs { $code .= "my \$value = "; if ($attr->should_coerce && $attr->type_constraint) { - $code .= "Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{find_type_constraint}, \$attrs[$index]->{type_constraint}, "; + $code .= "Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{type_constraint}, \$attrs[$index]->{type_constraint}, "; } if ($attr->has_builder) { @@ -105,7 +105,7 @@ sub _generate_processattrs { if ($attr->has_type_constraint) { $code .= "{ - unless (\$attrs[$index]->{find_type_constraint}->(\$value)) { + unless (\$attrs[$index]->{type_constraint}->check(\$value)) { \$attrs[$index]->verify_type_constraint_error('$key', \$_, \$attrs[$index]->type_constraint) } }"; diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm new file mode 100644 index 0000000..7b584bf --- /dev/null +++ b/lib/Mouse/Meta/TypeConstraint.pm @@ -0,0 +1,55 @@ +package Mouse::Meta::TypeConstraint; +use strict; +use warnings; +use overload '""' => sub { shift->{name} }, # stringify to tc name + fallback => 1; + +sub new { + my $class = shift; + my %args = @_; + my $name = $args{name} || '__ANON__'; + + 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}; + } + + bless +{ name => $name, _compiled_type_constraint => $check }, $class; +} + +sub name { shift->{name} } + +sub check { + my $self = shift; + $self->{_compiled_type_constraint}->(@_); +} + +1; +__END__ + +=head1 NAME + +Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass + +=head1 DESCRIPTION + +For the most part, the only time you will ever encounter an +instance of this class is if you are doing some serious deep +introspection. This API should not be considered final, but +it is B that this will matter to a regular +Mouse user. + +Don't use this. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=back + +=cut + diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 623599c..d4ef508 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -5,6 +5,7 @@ use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; +use Mouse::Meta::TypeConstraint; our @EXPORT = qw( as where message from via type subtype coerce class_type role_type enum @@ -63,8 +64,8 @@ BEGIN { Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, ); - foreach my $code (values %TYPE) { - bless $code, 'Mouse::Meta::TypeConstraint'; + while (my ($name, $code) = each %TYPE) { + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name ); } sub optimized_constraints { \%TYPE } @@ -89,7 +90,17 @@ sub type { }; $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) }; + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + name => $name, + _compiled_type_constraint => sub { + local $_ = $_[0]; + if (ref $constraint eq 'CODE') { + $constraint->($_[0]) + } else { + $constraint->check($_[0]) + } + } + ); } sub subtype { @@ -102,16 +113,20 @@ sub subtype { my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any'); $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = $constraint ? - sub { - local $_ = $_[0]; - $as_constraint->($_[0]) && $constraint->($_[0]) - } : - sub { - local $_ = $_[0]; - $as_constraint->($_[0]); - } - ; + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + name => $name, + _compiled_type_constraint => ( + $constraint ? + sub { + local $_ = $_[0]; + $as_constraint->check($_[0]) && $constraint->($_[0]) + } : + sub { + local $_ = $_[0]; + $as_constraint->check($_[0]); + } + ), + ); return $name; } @@ -168,18 +183,19 @@ sub role_type { ); } +# this is an original method for Mouse sub typecast_constraints { - my($class, $pkg, $type_constraint, $types, $value) = @_; + my($class, $pkg, $types, $value) = @_; local $_; - for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) { + for my $type ( split /\|/, $types ) { next unless $COERCE{$type}; for my $coerce_type (@{ $COERCE_KEYS{$type}}) { $_ = $value; - next unless $TYPE{$coerce_type}->($value); + next unless $TYPE{$coerce_type}->check($value); $_ = $value; $_ = $COERCE{$type}->{$coerce_type}->($value); - return $_ if $type_constraint->($_); + return $_ if $types->check($_); } } return $value; @@ -226,9 +242,9 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " if (\$parent->(\$_[0])) {\n" . + " if (\$parent->check(\$_[0])) {\n" . " foreach my \$e (\@{\$_[0]}) {\n" . - " return () unless \$child->(\$e);\n" . + " return () unless \$child->check(\$e);\n" . " }\n" . " return 1;\n" . " }\n" . @@ -240,9 +256,9 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " if (\$parent->(\$_[0])) {\n" . + " if (\$parent->check(\$_[0])) {\n" . " foreach my \$e (values \%{\$_[0]}) {\n" . - " return () unless \$child->(\$e);\n" . + " return () unless \$child->check(\$e);\n" . " }\n" . " return 1;\n" . " }\n" . @@ -254,14 +270,14 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" . + " return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" . "};\n" ; $code = eval $code_str or Carp::confess($@); } else { Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet"); } - $TYPE{$spec} = $code; + $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } else { $code = $TYPE{ $spec }; if (! $code) { @@ -272,10 +288,10 @@ sub _build_type_constraint { "}" ; $code = eval $code_str or Carp::confess($@); - $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint'; + $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } } - return bless $code, 'Mouse::Meta::TypeConstraint'; + return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } sub find_type_constraint { @@ -300,26 +316,21 @@ sub find_or_create_isa_type_constraint { my @code_list = map { $TYPE{$_} || _build_type_constraint($_) } @type_constraints; - $code = bless sub { - my $i = 0; - for my $code (@code_list) { - return 1 if $code->($_[0]); - } - return 0; - }, 'Mouse::Meta::TypeConstraint'; + $code = Mouse::Meta::TypeConstraint->new( + _compiled_type_constraint => sub { + my $i = 0; + for my $code (@code_list) { + return 1 if $code->check($_[0]); + } + return 0; + }, + name => $type_constraint, + ); } } return $code; } -package # Hide from pause - Mouse::Meta::TypeConstraint; - -sub check { - $_[0]->($_[1]) -} - - 1; __END__ diff --git a/t/800_shikabased/010-isa-or.t b/t/800_shikabased/010-isa-or.t index 0b42f5c..ef86743 100644 --- a/t/800_shikabased/010-isa-or.t +++ b/t/800_shikabased/010-isa-or.t @@ -32,7 +32,7 @@ my $f = Foo->new; eval { $f->bar([]); }; -ok !$@; +ok !$@, $@; is $f->bar, 'Baz', 'bar is baz (coerce from ArrayRef)'; eval { diff --git a/t/800_shikabased/014-subtype-as.t b/t/800_shikabased/014-subtype-as.t index 0a95057..3dc197b 100644 --- a/t/800_shikabased/014-subtype-as.t +++ b/t/800_shikabased/014-subtype-as.t @@ -64,6 +64,7 @@ isa_ok $f2, 'Foo'; is ref($f2->as_only), 'Obj1'; my $f3 = eval { Foo->new( any => Obj1->new ) }; +die $@ if $@; isa_ok $f3, 'Foo'; is ref($f3->any), 'Obj1';