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=808bb6b8def12625e695f0b5319f9656b8c6d28d;hp=b47a93b6a3355e839ff9f29f8817b48af248fc62;hb=9abaecfdec4e3ee1c8fae217b029a692155385a3;hpb=1e5823974a557bd35b4aa4a5c1d1aecf1e5483d2 diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index b47a93b..808bb6b 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -1,150 +1,192 @@ package Mouse::Util::TypeConstraints; -use Mouse::Util qw(does_role not_supported); # enables strict and warnings - -use Carp qw(confess); -use Scalar::Util (); +use Mouse::Util; # enables strict and warnings use Mouse::Meta::TypeConstraint; use Mouse::Exporter; +use Carp (); +use Scalar::Util (); + Mouse::Exporter->setup_import_methods( as_is => [qw( as where message optimize_as from via - type subtype coerce class_type role_type enum + + type subtype class_type role_type duck_type + enum + coerce + find_type_constraint + register_type_constraint )], ); +our @CARP_NOT = qw(Mouse::Meta::Attribute); + my %TYPE; -sub as ($) { (as => $_[0]) } -sub where (&) { (where => $_[0]) } -sub message (&) { (message => $_[0]) } -sub optimize_as (&) { (optimize_as => $_[0]) } +# The root type +$TYPE{Any} = Mouse::Meta::TypeConstraint->new( + name => 'Any', +); -sub from { @_ } -sub via (&) { $_[0] } - -BEGIN { - my %builtins = ( - Any => undef, # null check - Item => undef, # null check - Maybe => undef, # null check - - 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, +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, +); + +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, - ); - } +# parametarizable types +$TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for; +$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; +$TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for; - sub optimized_constraints { # DEPRECATED - Carp::cluck('optimized_constraints() has been deprecated'); - return \%TYPE; - } +# sugars +sub as ($) { (as => $_[0]) } ## no critic +sub where (&) { (where => $_[0]) } ## no critic +sub message (&) { (message => $_[0]) } ## no critic +sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic - my @builtins = keys %TYPE; - sub list_all_builtin_type_constraints { @builtins } +sub from { @_ } +sub via (&) { $_[0] } ## no critic + +# type utilities - sub list_all_type_constraints { keys %TYPE } +sub optimized_constraints { # DEPRECATED + Carp::cluck('optimized_constraints() has been deprecated'); + return \%TYPE; } -sub _create_type{ - my $mode = shift; +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 _define_type { + my $is_subtype = shift; my $name; my %args; - if(@_ == 1 && ref $_[0]){ # @_ : { name => $name, where => ... } + if(@_ == 1 && ref $_[0] ){ # @_ : { name => $name, where => ... } %args = %{$_[0]}; } - elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... } + elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... } $name = $_[0]; %args = %{$_[1]}; } - elsif(@_ % 2){ # @_ : $name => ( where => ... ) + elsif(@_ % 2) { # @_ : $name => ( where => ... ) ($name, %args) = @_; } - else{ # @_ : (name => $name, where => ...) + else{ # @_ : (name => $name, where => ...) %args = @_; } 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 = '__ANON__'; - } + + my $parent = delete $args{as}; + if($is_subtype && !$parent){ + $parent = delete $args{name}; + $name = undef; } - my $package_defined_in = $args{package_defined_in} ||= caller(1); + if(defined $parent) { + $args{parent} = find_or_create_isa_type_constraint($parent); + } - 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(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; + } + } + + if(defined $TYPE{$name}){ + my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__; + if($this ne $that) { + my $note = ''; + if($that eq __PACKAGE__) { + $note = sprintf " ('%s' is %s type constraint)", + $name, + scalar(grep { $name eq $_ } list_all_builtin_type_constraints()) + ? 'a builtin' + : 'an implicitly created'; + } + Carp::croak("The type constraint '$name' has already been created in $that" + . " and cannot be created again in $this" . $note); + } + } } $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'){ - $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args); + my $constraint = Mouse::Meta::TypeConstraint->new(%args); + + if(defined $name){ + return $TYPE{$name} = $constraint; } else{ - $constraint = Mouse::Meta::TypeConstraint->new(%args); + return $constraint; } - - return $TYPE{$name} = $constraint; } sub type { - return _create_type('type', @_); + return _define_type 0, @_; } sub subtype { - return _create_type('subtype', @_); + return _define_type 1, @_; } -sub coerce { +sub coerce { # coerce $type, from $from, via { ... }, ... my $type_name = shift; - my $type = find_type_constraint($type_name) - or confess("Cannot find type '$type_name', perhaps you forgot to load it."); + or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it."); $type->_add_type_coercions(@_); return; @@ -153,61 +195,83 @@ sub coerce { sub class_type { my($name, $options) = @_; my $class = $options->{class} || $name; - return _create_type 'subtype', $name => ( + + # ClassType + return subtype $name => ( as => 'Object', optimized_as => Mouse::Util::generate_isa_predicate_for($class), - - type => 'Class', + class => $class, ); } sub role_type { 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', + # RoleType + return subtype $name => ( + as => 'Object', + optimized_as => sub { + return Scalar::Util::blessed($_[0]) + && Mouse::Util::does_role($_[0], $role); + }, + role => $role, ); } -sub typecast_constraints { # DEPRECATED - my($class, $pkg, $type, $value) = @_; - Carp::croak("wrong arguments count") unless @_ == 4; +sub duck_type { + my($name, @methods); - Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway"); + if(ref($_[0]) ne 'ARRAY'){ + $name = shift; + } - return $type->coerce($value); + @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; + + # DuckType + return _define_type 1, $name => ( + as => 'Object', + optimized_as => Mouse::Util::generate_can_predicate_for(\@methods), + message => sub { + my($object) = @_; + my @missing = grep { !$object->can($_) } @methods; + return ref($object) + . ' is missing methods ' + . Mouse::Util::quoted_english_list(@missing); + }, + methods => \@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; } - return _create_type 'type', $name => ( - optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} }, - type => 'Enum', + %valid = map{ $_ => undef } + (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); + + # EnumType + return _define_type 1, $name => ( + as => 'Str', + optimized_as => sub{ + return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]}; + }, ); } sub _find_or_create_regular_type{ - my($spec) = @_; + my($spec, $create) = @_; return $TYPE{$spec} if exists $TYPE{$spec}; - my $meta = Mouse::Util::get_metaclass_by_name($spec) - or return undef; + my $meta = Mouse::Util::get_metaclass_by_name($spec); + + if(!defined $meta){ + return $create ? class_type($spec) : undef; + } if(Mouse::Util::is_a_metarole($meta)){ return role_type($spec); @@ -217,10 +281,6 @@ sub _find_or_create_regular_type{ } } -$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) = @_; @@ -230,103 +290,120 @@ sub _find_or_create_parameterized_type{ } sub _find_or_create_union_type{ + return if grep{ not defined } @_; my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; my $name = join '|', @types; + # UnionType $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( name => $name, type_constraints => \@types, - - type => 'Union', ); } # The type parser -sub _parse_type{ - my($spec, $start) = @_; - - my @list; - my $subtype; - - my $len = length $spec; - my $i; - - for($i = $start; $i < $len; $i++){ - my $char = substr($spec, $i, 1); - if($char eq '['){ - my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) ) - or return; +# param : '[' type ']' | NOTHING +sub _parse_param { + my($c) = @_; - ($i, $subtype) = _parse_type($spec, $i+1) - or return; - $start = $i+1; # reset + if($c->{spec} =~ s/^\[//){ + my $type = _parse_type($c, 1); - push @list, _find_or_create_parameterized_type($base => $subtype); + if($c->{spec} =~ s/^\]//){ + return $type; } - elsif($char eq ']'){ - $len = $i+1; - last; - } - elsif($char eq '|'){ - my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) ); + Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'"); + } - if(!defined $type){ - # XXX: Mouse creates a new class type, but Moose does not. - $type = class_type( substr($spec, $start, $i - $start) ); - } + return undef; +} - push @list, $type; +# name : [\w.:]+ +sub _parse_name { + my($c, $create) = @_; - ($i, $subtype) = _parse_type($spec, $i+1) - or return; + if($c->{spec} =~ s/\A ([\w.:]+) //xms){ + return _find_or_create_regular_type($1, $create); + } + Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'"); +} - $start = $i+1; # reset +# single_type : name param +sub _parse_single_type { + my($c, $create) = @_; - push @list, $subtype; - } - } - if($i - $start){ - my $type = _find_or_create_regular_type( substr $spec, $start, $i - $start ); + my $type = _parse_name($c, $create); + my $param = _parse_param($c); - if(defined $type){ - push @list, $type; + if(defined $type){ + if(defined $param){ + return _find_or_create_parameterized_type($type, $param); } - elsif($start != 0) { - # RT #50421 - # create a new class type - push @list, class_type( substr $spec, $start, $i - $start ); + else { + return $type; } } - - if(@list == 0){ - return; - } - elsif(@list == 1){ - return ($len, $list[0]); + elsif(defined $param){ + Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'"); } else{ - return ($len, _find_or_create_union_type(@list)); + return undef; } } +# type : single_type ('|' single_type)* +sub _parse_type { + my($c, $create) = @_; + + my $type = _parse_single_type($c, $create); + if($c->{spec}){ # can be an union type + my @types; + while($c->{spec} =~ s/^\|//){ + push @types, _parse_single_type($c, $create); + } + if(@types){ + return _find_or_create_union_type($type, @types); + } + } + return $type; +} + sub find_type_constraint { my($spec) = @_; - return $spec if Mouse::Util::is_a_type_constraint($spec); + return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec}; } +sub register_type_constraint { + my($constraint) = @_; + Carp::croak("No type supplied / type is not a valid type constraint") + unless Mouse::Util::is_a_type_constraint($constraint); + my $name = $constraint->name; + Carp::croak("Can't register an unnamed type constraint") + unless defined $name; + return $TYPE{$name} = $constraint; +} + sub find_or_parse_type_constraint { my($spec) = @_; - return $spec if Mouse::Util::is_a_type_constraint($spec); + return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec} || do{ - my($pos, $type) = _parse_type($spec, 0); + my $context = { + spec => $spec, + orig => $spec, + }; + my $type = _parse_type($context); + + if($context->{spec}){ + Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'"); + } $type; }; } @@ -342,7 +419,6 @@ sub find_or_create_isa_type_constraint { } 1; - __END__ =head1 NAME @@ -351,7 +427,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse =head1 VERSION -This document describes Mouse version 0.40_06 +This document describes Mouse version 0.76 =head2 SYNOPSIS @@ -419,18 +495,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] @@ -438,7 +514,7 @@ that hierarchy represented visually. CodeRef RegexpRef GlobRef - FileHandle + FileHandle Object B Any type followed by a type parameter C<[`a]> can be @@ -452,10 +528,6 @@ If Mouse finds a name in brackets that it does not recognize as an existing type, it assumes that this is a class name, for example C. -B Unless you parameterize a type, then it is invalid to include -the square brackets. I.e. C will be treated as a new type -name, I as a parameterization of C. - B The C type constraint for the most part works correctly now, but edge cases may still exist, please use it sparingly. @@ -524,16 +596,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 $name => as $parent => where { } ... -> Mouse::Meta::TypeConstraint >> -=item C<< subtype 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