use Carp 'confess';
use Scalar::Util ();
+use Mouse::Meta::TypeConstraint;
sub new {
my ($class, $name, %options) = @_;
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} }
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;
$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';
}
}
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.'} || [] };
}';
;
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);
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");
}
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 {
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
$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";
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)
}
}";
$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) {
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)
}
}";
--- /dev/null
+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<highly unlikely> that this will matter to a regular
+Mouse user.
+
+Don't use this.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<name>
+
+=back
+
+=cut
+
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
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 }
};
$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 {
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;
}
);
}
+# 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;
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" .
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" .
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) {
"}"
;
$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 {
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__
eval {
$f->bar([]);
};
-ok !$@;
+ok !$@, $@;
is $f->bar, 'Baz', 'bar is baz (coerce from ArrayRef)';
eval {
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';
projects / gitmo/Mouse.git / commitdiff