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=0e0c2b39d89382141336a2ac111e51390a33830e;hp=61205a0078a8f4d3eafd1da143742f1b36262a61;hb=72dc2c9d7f309b7e9216cdc7ab0e30feb0f2edd8;hpb=25f83ae1ee4aeed4ada879ffbd31a25b269efda8 diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 61205a0..0e0c2b3 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -1,91 +1,106 @@ 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; # get_metaclass_by_name() use Mouse::Meta::TypeConstraint; +use Mouse::Exporter; + +Mouse::Exporter->setup_import_methods( + as_is => [qw( + as where message optimize_as + from via + + type subtype class_type role_type duck_type + enum + coerce -our @ISA = qw(Exporter); -our @EXPORT = qw( - as where message from via type subtype coerce class_type role_type enum - find_type_constraint + 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]) -} +# The root type +$TYPE{Any} = Mouse::Meta::TypeConstraint->new( + name => 'Any', +); + +my @builtins = ( + # $name => $parent, $code, + + # the base type + Item => 'Any', undef, + + # the maybe[] type + Maybe => 'Item', undef, + + # value types + Undef => 'Item', \&Undef, + Defined => 'Item', \&Defined, + Bool => 'Item', \&Bool, + Value => 'Defined', \&Value, + Str => 'Value', \&Str, + Num => 'Str', \&Num, + Int => 'Num', \&Int, + + # ref types + Ref => 'Defined', \&Ref, + ScalarRef => 'Ref', \&ScalarRef, + ArrayRef => 'Ref', \&ArrayRef, + HashRef => 'Ref', \&HashRef, + CodeRef => 'Ref', \&CodeRef, + RegexpRef => 'Ref', \&RegexpRef, + GlobRef => 'Ref', \&GlobRef, + + # object types + FileHandle => 'GlobRef', \&FileHandle, + Object => 'Ref', \&Object, + + # special string types + ClassName => 'Str', \&ClassName, + RoleName => 'ClassName', \&RoleName, +); -sub from { @_ } -sub via (&) { $_[0] } -BEGIN { - my %builtins = ( - Any => undef, # null check - 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') }, +while (my ($name, $parent, $code) = splice @builtins, 0, 3) { + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + name => $name, + parent => $TYPE{$parent}, + optimized => $code, ); +} - while (my ($name, $code) = each %builtins) { - $TYPE{$name} = Mouse::Meta::TypeConstraint->new( - name => $name, - optimized => $code, - ); - } +# make it parametarizable - sub optimized_constraints { - Carp::cluck('optimized_constraints() has been deprecated'); - return \%TYPE; - } +$TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for; +$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; +$TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for; - my @builtins = keys %TYPE; - sub list_all_builtin_type_constraints { @builtins } +# sugars - sub list_all_type_constraints { keys %TYPE } +sub as ($) { (as => $_[0]) } +sub where (&) { (where => $_[0]) } +sub message (&) { (message => $_[0]) } +sub optimize_as (&) { (optimize_as => $_[0]) } + +sub from { @_ } +sub via (&) { $_[0] } + +# type utilities + +sub optimized_constraints { # DEPRECATED + Carp::cluck('optimized_constraints() has been deprecated'); + return \%TYPE; } +undef @builtins; # free the allocated memory +@builtins = keys %TYPE; # reuse it +sub list_all_builtin_type_constraints { @builtins } + +sub list_all_type_constraints { keys %TYPE } + sub _create_type{ my $mode = shift; @@ -107,36 +122,57 @@ sub _create_type{ } if(!defined $name){ - if(!defined($name = $args{name})){ - $name = '__ANON__'; - } + $name = $args{name}; } $args{name} = $name; + my $parent; + if($mode eq 'subtype'){ + $parent = delete $args{as}; + if(!$parent){ + $parent = delete $args{name}; + $name = undef; + } + } - my $package_defined_in = $args{package_defined_in} ||= caller(1); + if(defined $name){ + # set 'package_defined_in' only if it is not a core package + my $this = $args{package_defined_in}; + if(!$this){ + $this = caller(1); + if($this !~ /\A Mouse \b/xms){ + $args{package_defined_in} = $this; + } + } - my $existing = $TYPE{$name}; - if($existing && $existing->{package_defined_in} ne $package_defined_in){ - confess("The type constraint '$name' has already been created in " - . "$existing->{package_defined_in} and cannot be created again in $package_defined_in"); + if($TYPE{$name}){ + my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__; + ($this eq $that) or confess( + "The type constraint '$name' has already been created in $that and cannot be created again in $this" + ); + } + } + else{ + $args{name} = '__ANON__'; } - $args{constraint} = delete($args{where}) if exists $args{where}; + $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 = delete($args{as}) - or confess('A subtype cannot consist solely of a name, it must have a parent'); - $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args); } else{ $constraint = Mouse::Meta::TypeConstraint->new(%args); } - return $TYPE{$name} = $constraint; + if(defined $name){ + return $TYPE{$name} = $constraint; + } + else{ + return $constraint; + } } sub type { @@ -158,61 +194,54 @@ 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; - type => 'Class', - ); - } + # ClassType + return _create_type 'subtype', $name => ( + as => 'Object', + optimized_as => Mouse::Util::generate_isa_predicate_for($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; - type => 'Role', + # RoleType + return _create_type 'subtype', $name => ( + as => 'Object', + optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) }, ); } -sub typecast_constraints { - my($class, $pkg, $type, $value) = @_; - Carp::croak("wrong arguments count") unless @_ == 4; +sub duck_type { + my($name, @methods); + + if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){ + $name = shift; + } - Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway"); + @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; - return $type->coerce($value); + # DuckType + return _create_type 'type', $name => ( + optimized_as => Mouse::Util::generate_can_predicate_for(\@methods), + ); } sub enum { my($name, %valid); - # enum ['small', 'medium', 'large'] - if (ref($_[0]) eq 'ARRAY') { - %valid = map{ $_ => undef } @{ $_[0] }; - $name = sprintf '(%s)', join '|', sort @{$_[0]}; - } - # enum size => 'small', 'medium', 'large' - else{ - $name = shift; - %valid = map{ $_ => undef } @_; + if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){ + $name = shift; } + + %valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); + + # EnumType return _create_type 'type', $name => ( optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} }, - - type => 'Enum', ); } @@ -221,102 +250,35 @@ sub _find_or_create_regular_type{ return $TYPE{$spec} if exists $TYPE{$spec}; - my $meta = Mouse::Meta::Module::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->($_); - }; -}; - 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 = map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; - my $name = join '|', map{ $_->name } @types; +sub _find_or_create_union_type{ + my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; - $TYPE{$name} ||= do{ - return Mouse::Meta::TypeConstraint->new( - name => $name, - type_constraints => \@types, + my $name = join '|', @types; - type => 'Union', - ); - }; + # UnionType + $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( + name => $name, + type_constraints => \@types, + ); } # The type parser @@ -365,7 +327,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){ @@ -382,7 +353,8 @@ 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); + return undef if !defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec}; @@ -390,7 +362,8 @@ 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); + return undef if !defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec} || do{ @@ -400,26 +373,26 @@ 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(@_); } 1; - __END__ =head1 NAME Mouse::Util::TypeConstraints - Type constraint system for Mouse +=head1 VERSION + +This document describes Mouse version 0.50_03 + =head2 SYNOPSIS use Mouse::Util::TypeConstraints; @@ -486,18 +459,18 @@ yet to have been created, is to quote the type name: This module also provides a simple hierarchy for Perl 5 types, here is that hierarchy represented visually. - Any + Any Item Bool Maybe[`a] Undef Defined Value - Num - Int Str - ClassName - RoleName + Num + Int + ClassName + RoleName Ref ScalarRef ArrayRef[`a] @@ -505,7 +478,7 @@ that hierarchy represented visually. CodeRef RegexpRef GlobRef - FileHandle + FileHandle Object B Any type followed by a type parameter C<[`a]> can be @@ -591,16 +564,26 @@ Returns the names of all the type constraints. =over 4 -=item C<< subtype 'Name' => as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >> +=item C<< type $name => where { } ... -> Mouse::Meta::TypeConstraint >> -=item C<< subtype as 'Parent' => where { } ... -> Mouse::Meta::TypeConstraint >> +=item C<< subtype $name => as $parent => where { } ... -> Mouse::Meta::TypeConstraint >> + +=item C<< subtype as $parent => where { } ... -> Mouse::Meta::TypeConstraint >> =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >> =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >> +=item C<< duck_type($name, @methods | \@methods) -> Mouse::Meta::TypeConstraint >> + +=item C<< duck_type(\@methods) -> Mouse::Meta::TypeConstraint >> + +=item C<< enum($name, @values | \@values) -> Mouse::Meta::TypeConstraint >> + =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >> +=item C<< coerce $type => from $another_type, via { }, ... >> + =back =over 4