X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=d4ef508dddbe3a4080144e79cb36b3327f834215;hb=684db121da77d6c63be5a58e33606907ca2aa4fb;hp=6410243a857debfb2498eb72fa412b647bb70280;hpb=310ad28b79e8761d5f8b24e54e06d3ebd3ad59b7;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 6410243..d4ef508 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -5,9 +5,11 @@ 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 + find_type_constraint ); my %TYPE; @@ -30,40 +32,41 @@ sub via (&) { $_[0] } -my $optimized_constraints; -my $optimized_constraints_base; -{ +BEGIN { no warnings 'uninitialized'; %TYPE = ( Any => sub { 1 }, Item => sub { 1 }, Bool => sub { - !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' + !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0' }, - Undef => sub { !defined($_) }, - Defined => sub { defined($_) }, - Value => sub { defined($_) && !ref($_) }, - Num => sub { !ref($_) && looks_like_number($_) }, - Int => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ }, - Str => sub { defined($_) && !ref($_) }, - ClassName => sub { Mouse::is_class_loaded($_) }, - Ref => sub { ref($_) }, - - ScalarRef => sub { ref($_) eq 'SCALAR' }, - ArrayRef => sub { ref($_) eq 'ARRAY' }, - HashRef => sub { ref($_) eq 'HASH' }, - CodeRef => sub { ref($_) eq 'CODE' }, - RegexpRef => sub { ref($_) eq 'Regexp' }, - GlobRef => sub { ref($_) eq 'GLOB' }, + Undef => sub { !defined($_[0]) }, + Defined => sub { defined($_[0]) }, + Value => sub { defined($_[0]) && !ref($_[0]) }, + Num => sub { !ref($_[0]) && looks_like_number($_[0]) }, + Int => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }, + Str => sub { defined($_[0]) && !ref($_[0]) }, + ClassName => sub { Mouse::is_class_loaded($_[0]) }, + Ref => sub { ref($_[0]) }, + + ScalarRef => sub { ref($_[0]) eq 'SCALAR' }, + ArrayRef => sub { ref($_[0]) eq 'ARRAY' }, + HashRef => sub { ref($_[0]) eq 'HASH' }, + CodeRef => sub { ref($_[0]) eq 'CODE' }, + RegexpRef => sub { ref($_[0]) eq 'Regexp' }, + GlobRef => sub { ref($_[0]) eq 'GLOB' }, FileHandle => sub { - ref($_) eq 'GLOB' && openhandle($_) + ref($_[0]) eq 'GLOB' && openhandle($_[0]) or - blessed($_) && $_->isa("IO::Handle") + blessed($_[0]) && $_[0]->isa("IO::Handle") }, - Object => sub { blessed($_) && blessed($_) ne 'Regexp' }, + Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, ); + while (my ($name, $code) = each %TYPE) { + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name ); + } sub optimized_constraints { \%TYPE } my @TYPE_KEYS = keys %TYPE; @@ -78,10 +81,26 @@ sub type { if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) { Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg"; }; - my $constraint = $conf{where} || do { $TYPE{delete $conf{as} || 'Any' } }; + my $constraint = $conf{where} || do { + my $as = delete $conf{as} || 'Any'; + if (! exists $TYPE{$as}) { + $TYPE{$as} = _build_type_constraint($as); + } + $TYPE{$as}; + }; $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = $constraint; + $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 { @@ -90,22 +109,26 @@ sub subtype { if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) { Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg"; }; - my $constraint = $conf{where} || do { - my $as = delete $conf{as} || 'Any'; - if (! exists $TYPE{$as}) { # Perhaps it's a parameterized source? - Mouse::Meta::Attribute::_build_type_constraint($as); - } - $TYPE{$as}; - }; - my $as = $conf{as} || ''; + my $constraint = $conf{where}; + my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any'); $TYPE_SOURCE{$name} = $pkg; + $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]); + } + ), + ); - if ($as = $TYPE{$as}) { - $TYPE{$name} = sub { $as->($_) && $constraint->($_) }; - } else { - $TYPE{$name} = $constraint; - } + return $name; } sub coerce { @@ -125,7 +148,7 @@ sub coerce { if (! $TYPE{$type}) { # looks parameterized if ($type =~ /^[^\[]+\[.+\]$/) { - Mouse::Meta::Attribute::_build_type_constraint($type); + $TYPE{$type} = _build_type_constraint($type); } else { Carp::croak "Could not find the type constraint ($type) to coerce from" } @@ -137,12 +160,16 @@ sub coerce { } sub class_type { - my $pkg = caller(0); my($name, $conf) = @_; - my $class = $conf->{class}; - subtype( - $name => where => sub { $_->isa($class) } - ); + if ($conf && $conf->{class}) { + # No, you're using this wrong + warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?"; + subtype($name, as => $conf->{class}); + } else { + subtype( + $name => where => sub { $_->isa($name) } + ); + } } sub role_type { @@ -156,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}->(); + next unless $TYPE{$coerce_type}->check($value); $_ = $value; - $_ = $COERCE{$type}->{$coerce_type}->(); - return $_ if $type_constraint->(); + $_ = $COERCE{$type}->{$coerce_type}->($value); + return $_ if $types->check($_); } } return $value; @@ -194,6 +222,115 @@ sub enum { ); } +sub _build_type_constraint { + + my $spec = shift; + my $code; + $spec =~ s/\s+//g; + if ($spec =~ /^([^\[]+)\[(.+)\]$/) { + # parameterized + my $constraint = $1; + my $param = $2; + my $parent; + if ($constraint eq 'Maybe') { + $parent = _build_type_constraint('Undef'); + } else { + $parent = _build_type_constraint($constraint); + } + my $child = _build_type_constraint($param); + if ($constraint eq 'ArrayRef') { + my $code_str = + "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . + "sub {\n" . + " if (\$parent->check(\$_[0])) {\n" . + " foreach my \$e (\@{\$_[0]}) {\n" . + " return () unless \$child->check(\$e);\n" . + " }\n" . + " return 1;\n" . + " }\n" . + " return ();\n" . + "};\n" + ; + $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@"); + } elsif ($constraint eq 'HashRef') { + my $code_str = + "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . + "sub {\n" . + " if (\$parent->check(\$_[0])) {\n" . + " foreach my \$e (values \%{\$_[0]}) {\n" . + " return () unless \$child->check(\$e);\n" . + " }\n" . + " return 1;\n" . + " }\n" . + " return ();\n" . + "};\n" + ; + $code = eval $code_str or Carp::confess($@); + } elsif ($constraint eq 'Maybe') { + my $code_str = + "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . + "sub {\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} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); + } else { + $code = $TYPE{ $spec }; + if (! $code) { + my $code_str = + "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . + "sub {\n" . + " Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" . + "}" + ; + $code = eval $code_str or Carp::confess($@); + $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); + } + } + return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); +} + +sub find_type_constraint { + my $type_constraint = shift; + return $TYPE{$type_constraint}; +} + +sub find_or_create_isa_type_constraint { + my $type_constraint = shift; + + my $code; + + $type_constraint =~ s/\s+//g; + + $code = $TYPE{$type_constraint}; + if (! $code) { + my @type_constraints = split /\|/, $type_constraint; + if (@type_constraints == 1) { + $code = $TYPE{$type_constraints[0]} || + _build_type_constraint($type_constraints[0]); + } else { + my @code_list = map { + $TYPE{$_} || _build_type_constraint($_) + } @type_constraints; + $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; +} + 1; __END__ @@ -208,6 +345,22 @@ Mouse::Util::TypeConstraints - simple type constraints Returns the simple type constraints that Mouse understands. +=head1 FUNCTIONS + +=over 4 + +=item B as 'Parent' => where { } ...> + +=item B where { } ...> + +=item B + +=item B + +=item B + +=back + =cut