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=dcad15c616198006c9e34ef639d1ee4fed231262;hp=8cbcc26683b471da76317cf88d9b4d68f1ac2250;hb=1820fffecb0bd1da64edc16ecde534178b841d14;hpb=73766a27db7dcd127e0397d83186dadfcda398a9 diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 8cbcc26..dcad15c 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -6,7 +6,8 @@ use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; -use Mouse::Util; +use Mouse::Util qw(does_role not_supported); +use Mouse::Meta::Module; # class_of use Mouse::Meta::TypeConstraint; our @EXPORT = qw( @@ -33,8 +34,7 @@ sub from { @_ } sub via (&) { $_[0] } BEGIN { - no warnings 'uninitialized'; - %TYPE = ( + my %builtins = ( Any => sub { 1 }, Item => sub { 1 }, @@ -63,20 +63,23 @@ BEGIN { Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, ClassName => sub { Mouse::Util::is_class_loaded($_[0]) }, - RoleName => sub { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }, + RoleName => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') }, ); - while (my ($name, $code) = each %TYPE) { + + while (my ($name, $code) = each %builtins) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( name => $name, _compiled_type_constraint => $code, ); + $TYPE_SOURCE{$name} = __PACKAGE__; } sub optimized_constraints { \%TYPE } - my @TYPE_KEYS = keys %TYPE; - sub list_all_builtin_type_constraints { @TYPE_KEYS } - @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS; + my @builtins = keys %TYPE; + sub list_all_builtin_type_constraints { @builtins } + + sub list_all_type_constraints { keys %TYPE } } sub type { @@ -105,26 +108,24 @@ 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 { my $as = delete $conf{as} || 'Any'; - if (! exists $TYPE{$as}) { - $TYPE{$as} = _build_type_constraint($as); - } - $TYPE{$as}; + ($TYPE{$as} ||= _build_type_constraint($as))->{_compiled_type_constraint}; }; - $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = Mouse::Meta::TypeConstraint->new( - name => $name, + my $tc = Mouse::Meta::TypeConstraint->new( + name => $name, _compiled_type_constraint => sub { local $_ = $_[0]; - if (ref $constraint eq 'CODE') { - $constraint->($_[0]) - } else { - $constraint->check($_[0]) - } - } + return &{$constraint}; + }, ); + + $TYPE_SOURCE{$name} = $pkg; + $TYPE{$name} = $tc; + + return $tc; } sub subtype { @@ -150,31 +151,34 @@ sub subtype { my $pkg = caller; - 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 = delete $conf{where}; - my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any'); - $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + my $constraint = delete $conf{where}; + my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any') + ->{_compiled_type_constraint}; + + my $tc = Mouse::Meta::TypeConstraint->new( name => $name, _compiled_type_constraint => ( $constraint ? sub { local $_ = $_[0]; - $as_constraint->check($_[0]) && $constraint->($_[0]) + $as_constraint->($_[0]) && $constraint->($_[0]) } : sub { local $_ = $_[0]; - $as_constraint->check($_[0]); + $as_constraint->($_[0]); } ), - %conf + %conf, ); - return $name; + $TYPE_SOURCE{$name} = $pkg; + $TYPE{$name} = $tc; + + return $tc; } sub coerce { @@ -212,10 +216,11 @@ sub class_type { 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) } + subtype $name => (as => $conf->{class}); + } + else { + subtype $name => ( + where => sub { blessed($_) && $_->isa($name) }, ); } } @@ -223,18 +228,15 @@ sub class_type { sub role_type { my($name, $conf) = @_; my $role = $conf->{role}; - subtype( - $name => where => sub { - return unless defined $_ && ref($_) && $_->isa('Mouse::Object'); - $_->meta->does_role($role); - } + subtype $name => ( + where => sub { does_role($_, $role) }, ); } # this is an original method for Mouse sub typecast_constraints { my($class, $pkg, $types, $value) = @_; - Carp::croak("wrong arguments count") unless @_==4; + Carp::croak("wrong arguments count") unless @_ == 4; local $_; for my $type ( split /\|/, $types ) { @@ -272,18 +274,21 @@ sub enum { } sub _build_type_constraint { + my($spec) = @_; - my $spec = shift; my $code; $spec =~ s/\s+//g; - if ($spec =~ /^([^\[]+)\[(.+)\]$/) { + + if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) { # parameterized my $constraint = $1; my $param = $2; my $parent; + if ($constraint eq 'Maybe') { $parent = _build_type_constraint('Undef'); - } else { + } + else { $parent = _build_type_constraint($constraint); } my $child = _build_type_constraint($param); @@ -348,8 +353,17 @@ sub _build_type_constraint { } sub find_type_constraint { - my $type_constraint = shift; - return $TYPE{$type_constraint}; + my($type) = @_; + if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){ + return $type; + } + else{ + return $TYPE{$type}; + } +} + +sub find_or_create_does_type_constraint{ + not_supported; } sub find_or_create_isa_type_constraint { @@ -362,33 +376,34 @@ sub find_or_create_isa_type_constraint { $1 ne 'Maybe' ; - my $code; $type_constraint =~ s/\s+//g; - $code = $TYPE{$type_constraint}; - if (! $code) { + my $tc = find_type_constraint($type_constraint); + if (!$tc) { my @type_constraints = split /\|/, $type_constraint; if (@type_constraints == 1) { - $code = $TYPE{$type_constraints[0]} || + $tc = $TYPE{$type_constraints[0]} || _build_type_constraint($type_constraints[0]); - } else { + } + else { my @code_list = map { $TYPE{$_} || _build_type_constraint($_) } @type_constraints; - $code = Mouse::Meta::TypeConstraint->new( + + $tc = Mouse::Meta::TypeConstraint->new( + name => $type_constraint, + _compiled_type_constraint => sub { - my $i = 0; - for my $code (@code_list) { + foreach my $code (@code_list) { return 1 if $code->check($_[0]); } return 0; }, - name => $type_constraint, ); } } - return $code; + return $tc; } 1; @@ -567,21 +582,31 @@ Returns the simple type constraints that Mouse understands. =over 4 -=item B as 'Parent' => where { } ...> +=item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >> -=item B where { } ...> +=item C<< subtype as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >> -=item B +=item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >> -=item B +=item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >> -=item B +=item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >> + +=back + +=over 4 + +=item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >> =back =head1 THANKS -Much of this documentation was taken from L +Much of this documentation was taken from C + +=head1 SEE ALSO + +L =cut