X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=9658ca5b76a8bf9a7ddcd896ed86de0fb72c2ed5;hp=56d4734a09c1c25414c7099e20c1616957d72e3e;hb=619338ac4245c7c523d67645d6cd51cb982d4841;hpb=9b9e4b6566015d6d6e2aa6c745644174efa74623 diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 56d4734..9658ca5 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -2,7 +2,7 @@ package Mouse::Util::TypeConstraints; use Mouse::Util qw(does_role not_supported); # enables strict and warnings use Carp qw(confess); -use Scalar::Util qw/blessed looks_like_number openhandle/; +use Scalar::Util (); use Mouse::Meta::TypeConstraint; use Mouse::Exporter; @@ -14,15 +14,13 @@ Mouse::Exporter->setup_import_methods( type subtype coerce class_type role_type enum find_type_constraint )], - - _export_to_main => 1, ); my %TYPE; -sub as ($) { (as => $_[0]) } -sub where (&) { (where => $_[0]) } -sub message (&) { (message => $_[0]) } +sub as ($) { (as => $_[0]) } +sub where (&) { (where => $_[0]) } +sub message (&) { (message => $_[0]) } sub optimize_as (&) { (optimize_as => $_[0]) } sub from { @_ } @@ -34,32 +32,28 @@ BEGIN { Item => undef, # null check Maybe => undef, # null check - Bool => sub { $_[0] ? $_[0] eq '1' : 1 }, - 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]) }, - 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($_[0]) eq 'GLOB' && openhandle($_[0]) - or - blessed($_[0]) && $_[0]->isa("IO::Handle") - }, - - Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, - - ClassName => sub { Mouse::Util::is_class_loaded($_[0]) }, - RoleName => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') }, + Bool => \&Bool, + Undef => \&Undef, + Defined => \&Defined, + Value => \&Value, + Num => \&Num, + Int => \&Int, + Str => \&Str, + Ref => \&Ref, + + ScalarRef => \&ScalarRef, + ArrayRef => \&ArrayRef, + HashRef => \&HashRef, + CodeRef => \&CodeRef, + RegexpRef => \&RegexpRef, + GlobRef => \&GlobRef, + + FileHandle => \&FileHandle, + + Object => \&Object, + + ClassName => \&ClassName, + RoleName => \&RoleName, ); while (my ($name, $code) = each %builtins) { @@ -157,30 +151,22 @@ sub coerce { } sub class_type { - my($name, $conf) = @_; - 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}'?"; - _create_type 'type', $name => ( - as => $conf->{class}, - - type => 'Class', - ); - } - else { - _create_type 'type', $name => ( - optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) }, + my($name, $options) = @_; + my $class = $options->{class} || $name; + return _create_type 'subtype', $name => ( + as => 'Object', + optimized_as => Mouse::Util::generate_isa_predicate_for($class), - type => 'Class', - ); - } + type => 'Class', + ); } sub role_type { - my($name, $conf) = @_; - my $role = ($conf && $conf->{role}) ? $conf->{role} : $name; - _create_type 'type', $name => ( - optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) }, + my($name, $options) = @_; + my $role = $options->{role} || $name; + return _create_type 'subtype', $name => ( + as => 'Object', + optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) }, type => 'Role', ); @@ -220,102 +206,40 @@ sub _find_or_create_regular_type{ return $TYPE{$spec} if exists $TYPE{$spec}; - my $meta = Mouse::Util::get_metaclass_by_name($spec); + my $meta = Mouse::Util::get_metaclass_by_name($spec) + or return undef; - if(!$meta){ - return; - } - - my $check; - my $type; - if($meta->isa('Mouse::Meta::Role')){ - $check = sub{ - return blessed($_[0]) && $_[0]->does($spec); - }; - $type = 'Role'; + if(Mouse::Util::is_a_metarole($meta)){ + return role_type($spec); } else{ - $check = sub{ - return blessed($_[0]) && $_[0]->isa($spec); - }; - $type = 'Class'; + return class_type($spec); } - - return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( - name => $spec, - optimized => $check, - - type => $type, - ); } -$TYPE{ArrayRef}{constraint_generator} = sub { - my($type_parameter) = @_; - my $check = $type_parameter->_compiled_type_constraint; - - return sub{ - foreach my $value (@{$_}) { - return undef unless $check->($value); - } - return 1; - } -}; -$TYPE{HashRef}{constraint_generator} = sub { - my($type_parameter) = @_; - my $check = $type_parameter->_compiled_type_constraint; - - return sub{ - foreach my $value(values %{$_}){ - return undef unless $check->($value); - } - return 1; - }; -}; - -# 'Maybe' type accepts 'Any', so it requires parameters -$TYPE{Maybe}{constraint_generator} = sub { - my($type_parameter) = @_; - my $check = $type_parameter->_compiled_type_constraint; - - return sub{ - return !defined($_) || $check->($_); - }; -}; +$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; +$TYPE{HashRef}{constraint_generator} = \&_parameterize_HashRef_for; +$TYPE{Maybe}{constraint_generator} = \&_parameterize_Maybe_for; sub _find_or_create_parameterized_type{ my($base, $param) = @_; my $name = sprintf '%s[%s]', $base->name, $param->name; - $TYPE{$name} ||= do{ - my $generator = $base->{constraint_generator}; - - if(!$generator){ - confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type"); - } - - Mouse::Meta::TypeConstraint->new( - name => $name, - parent => $base, - constraint => $generator->($param), - - type => 'Parameterized', - ); - } + $TYPE{$name} ||= $base->parameterize($param, $name); } + sub _find_or_create_union_type{ - my @types = sort{ $a cmp $b } map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; + my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; my $name = join '|', @types; - $TYPE{$name} ||= do{ - return Mouse::Meta::TypeConstraint->new( - name => $name, - type_constraints => \@types, + $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( + name => $name, + type_constraints => \@types, - type => 'Union', - ); - }; + type => 'Union', + ); } # The type parser @@ -390,7 +314,7 @@ sub _parse_type{ sub find_type_constraint { my($spec) = @_; - return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint'); + return $spec if Mouse::Util::is_a_type_constraint($spec); $spec =~ s/\s+//g; return $TYPE{$spec}; @@ -398,7 +322,7 @@ sub find_type_constraint { sub find_or_parse_type_constraint { my($spec) = @_; - return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint'); + return $spec if Mouse::Util::is_a_type_constraint($spec); $spec =~ s/\s+//g; return $TYPE{$spec} || do{ @@ -408,10 +332,12 @@ sub find_or_parse_type_constraint { } sub find_or_create_does_type_constraint{ + # XXX: Moose does not register a new role_type, but Mouse does. return find_or_parse_type_constraint(@_) || role_type(@_); } sub find_or_create_isa_type_constraint { + # XXX: Moose does not register a new class_type, but Mouse does. return find_or_parse_type_constraint(@_) || class_type(@_); } @@ -425,7 +351,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse =head1 VERSION -This document describes Mouse version 0.39 +This document describes Mouse version 0.40_03 =head2 SYNOPSIS