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=d4db67312087dd3712a153832abfe1521c910df0;hb=619338ac4245c7c523d67645d6cd51cb982d4841;hpb=e3281eafbd3005f63707187c9eab7952f9daedfc diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index d4db673..9658ca5 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -1,37 +1,27 @@ package Mouse::Util::TypeConstraints; -use strict; -use warnings; - -use Exporter; +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::Util qw(does_role not_supported); -use Mouse::Meta::Module; # class_of use Mouse::Meta::TypeConstraint; - -use constant _DEBUG => !!$ENV{TC_DEBUG}; - -our @ISA = qw(Exporter); -our @EXPORT = qw( - as where message from via type subtype coerce class_type role_type enum - find_type_constraint +use Mouse::Exporter; + +Mouse::Exporter->setup_import_methods( + as_is => [qw( + as where message optimize_as + from via + type subtype coerce class_type role_type enum + find_type_constraint + )], ); my %TYPE; -my %COERCE; -my %COERCE_KEYS; -sub as ($) { - return(as => $_[0]); -} -sub where (&) { - return(where => $_[0]) -} -sub message (&) { - return(message => $_[0]) -} +sub as ($) { (as => $_[0]) } +sub where (&) { (where => $_[0]) } +sub message (&) { (message => $_[0]) } +sub optimize_as (&) { (optimize_as => $_[0]) } sub from { @_ } sub via (&) { $_[0] } @@ -42,43 +32,38 @@ 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) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( - name => $name, - _compiled_type_constraint => $code, - package_defined_in => __PACKAGE__, + name => $name, + optimized => $code, ); } - sub optimized_constraints { + sub optimized_constraints { # DEPRECATED Carp::cluck('optimized_constraints() has been deprecated'); return \%TYPE; } @@ -116,6 +101,14 @@ sub _create_type{ } $args{name} = $name; + my $parent; + if($mode eq 'subtype'){ + $parent = delete $args{as}; + if(!$parent){ + $parent = delete $args{name}; + $name = '__ANON__'; + } + } my $package_defined_in = $args{package_defined_in} ||= caller(1); @@ -125,17 +118,12 @@ sub _create_type{ . "$existing->{package_defined_in} and cannot be created again in $package_defined_in"); } - $args{constraint} = delete($args{where}) - if exists $args{where}; - $args{_compiled_type_constraint} = delete $args{optimized_as} - if exists $args{optimized_as}; + $args{constraint} = delete $args{where} if exists $args{where}; + $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as}; my $constraint; if($mode eq 'subtype'){ - my $parent = exists($args{as}) ? delete($args{as}) : delete($args{name}); - - $parent = blessed($parent) ? $parent : find_or_create_isa_type_constraint($parent); - $constraint = $parent->create_child_type(%args); + $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args); } else{ $constraint = Mouse::Meta::TypeConstraint->new(%args); @@ -153,98 +141,44 @@ sub subtype { } sub coerce { - my $name = shift; - - $name =~ s/\s+//g; - confess "Cannot find type '$name', perhaps you forgot to load it." - unless $TYPE{$name}; - - unless ($COERCE{$name}) { - $COERCE{$name} = {}; - $COERCE_KEYS{$name} = []; - } - - my $package_defined_in = caller; - - while (my($from, $code) = splice @_, 0, 2) { - $from =~ s/\s+//g; - - confess "A coercion action already exists for '$from'" - if $COERCE{$name}->{$from}; + my $type_name = shift; - my $type = find_or_parse_type_constraint($from, $package_defined_in); - if (!$type) { - confess "Could not find the type constraint ($from) to coerce from" - } - - warn "# REGISTER COERCE $name, from $type\n" if _DEBUG; + my $type = find_type_constraint($type_name) + or confess("Cannot find type '$type_name', perhaps you forgot to load it."); - push @{ $COERCE_KEYS{$name} }, $type; - $COERCE{$name}->{$from} = $code; - } + $type->_add_type_coercions(@_); return; } 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', ); } -# this is an original method for Mouse -sub typecast_constraints { - my($class, $pkg, $types, $value) = @_; +sub typecast_constraints { # DEPRECATED + my($class, $pkg, $type, $value) = @_; Carp::croak("wrong arguments count") unless @_ == 4; - local $_; - for my $type ($types, ($types->{type_constraints} ? @{$types->{type_constraints}} : ()) ) { - for my $coerce_type (@{ $COERCE_KEYS{$type}}) { - - if(_DEBUG){ - warn sprintf "# COERCE: from %s to %s for %s (%s)\n", - $coerce_type, $type, defined($value) ? $value : 'undef', - $coerce_type->check($value) ? "try" : "skip"; - } - - next if !$coerce_type->check($value); + Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway"); - # try to coerce - $_ = $value; - $_ = $COERCE{$type}->{$coerce_type}->($_); # coerce - - if(_DEBUG){ - warn sprintf "# COERCE: got %s, which is%s %s\n", - defined($_) ? $_ : 'undef', $types->check($_) ? '' : ' not', $types; - } - - return $_ if $types->check($_); # check for $types, not $constraint - } - } - return $value; + return $type->coerce($value); } sub enum { @@ -272,116 +206,40 @@ sub _find_or_create_regular_type{ return $TYPE{$spec} if exists $TYPE{$spec}; - my $meta = Mouse::Meta::Module::class_of($spec); + my $meta = Mouse::Util::get_metaclass_by_name($spec) + or return undef; - if(!$meta){ - return; - } - - my $check; - my $type; - if($meta && $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); } - - warn "#CREATE a $type type for $spec\n" if _DEBUG; - - return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( - name => $spec, - _compiled_type_constraint => $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{ - warn "#CREATE a Parameterized type for $name\n" if _DEBUG; - - 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 = map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; - - my $name = join '|', map{ $_->name } @types; - $TYPE{$name} ||= do{ - warn "# CREATE a Union type for ", Mouse::Util::english_list(@types),"\n" if _DEBUG; +sub _find_or_create_union_type{ + my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; - my $check = sub{ - foreach my $type(@types){ - return 1 if $type->check($_[0]); - } - return 0; - }; + my $name = join '|', @types; - return Mouse::Meta::TypeConstraint->new( - name => $name, - _compiled_type_constraint => $check, - type_constraints => \@types, + $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( + name => $name, + type_constraints => \@types, - type => 'Union', - ); - }; + type => 'Union', + ); } # The type parser @@ -398,7 +256,7 @@ sub _parse_type{ my $char = substr($spec, $i, 1); if($char eq '['){ - my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start)) + my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) ) or return; ($i, $subtype) = _parse_type($spec, $i+1) @@ -412,8 +270,12 @@ sub _parse_type{ last; } elsif($char eq '|'){ - my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start)) - or return; + my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) ); + + if(!defined $type){ + # XXX: Mouse creates a new class type, but Moose does not. + $type = class_type( substr($spec, $start, $i - $start) ); + } push @list, $type; @@ -426,7 +288,16 @@ sub _parse_type{ } } if($i - $start){ - push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start); + my $type = _find_or_create_regular_type( substr $spec, $start, $i - $start ); + + if(defined $type){ + push @list, $type; + } + elsif($start != 0) { + # RT #50421 + # create a new class type + push @list, class_type( substr $spec, $start, $i - $start ); + } } if(@list == 0){ @@ -443,7 +314,7 @@ sub _parse_type{ sub find_type_constraint { my($spec) = @_; - return $spec if blessed($spec); + return $spec if Mouse::Util::is_a_type_constraint($spec); $spec =~ s/\s+//g; return $TYPE{$spec}; @@ -451,8 +322,7 @@ sub find_type_constraint { sub find_or_parse_type_constraint { my($spec) = @_; - - return $spec if blessed($spec); + return $spec if Mouse::Util::is_a_type_constraint($spec); $spec =~ s/\s+//g; return $TYPE{$spec} || do{ @@ -462,15 +332,12 @@ sub find_or_parse_type_constraint { } sub find_or_create_does_type_constraint{ - my $type = find_or_parse_type_constriant(@_) || role_type(@_); - - if($type->{type} && $type->{type} ne 'Role'){ - Carp::cluck("$type is not a role type"); - } - return $type; + # 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(@_); } @@ -482,6 +349,10 @@ __END__ Mouse::Util::TypeConstraints - Type constraint system for Mouse +=head1 VERSION + +This document describes Mouse version 0.40_03 + =head2 SYNOPSIS use Mouse::Util::TypeConstraints; @@ -641,9 +512,13 @@ related C function. =head1 METHODS -=head2 optimized_constraints -> HashRef[CODE] +=head2 C<< list_all_builtin_type_constraints -> (Names) >> + +Returns the names of builtin type constraints. + +=head2 C<< list_all_type_constraints -> (Names) >> -Returns the simple type constraints that Mouse understands. +Returns the names of all the type constraints. =head1 FUNCTIONS