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=6b811545fcbfd2eca44989761d700fa5935db514;hb=9abaecfdec4e3ee1c8fae217b029a692155385a3;hpb=c06ab42929c96053e941120f1469aeee65e63149 diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 6b81154..808bb6b 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -1,12 +1,12 @@ package Mouse::Util::TypeConstraints; -use Mouse::Util qw(does_role not_supported); # enables strict and warnings - -use Carp (); -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 @@ -66,7 +66,6 @@ my @builtins = ( RoleName => 'ClassName', \&RoleName, ); - while (my ($name, $parent, $code) = splice @builtins, 0, 3) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( name => $name, @@ -75,14 +74,12 @@ while (my ($name, $parent, $code) = splice @builtins, 0, 3) { ); } -# make it parametarizable - +# parametarizable types $TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for; $TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; $TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for; # sugars - sub as ($) { (as => $_[0]) } ## no critic sub where (&) { (where => $_[0]) } ## no critic sub message (&) { (message => $_[0]) } ## no critic @@ -101,26 +98,24 @@ sub optimized_constraints { # DEPRECATED 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; - +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 = @_; } @@ -129,13 +124,15 @@ sub _create_type{ } $args{name} = $name; - my $parent; - if($mode eq 'subtype'){ - $parent = delete $args{as}; - if(!$parent){ - $parent = delete $args{name}; - $name = undef; - } + + my $parent = delete $args{as}; + if($is_subtype && !$parent){ + $parent = delete $args{name}; + $name = undef; + } + + if(defined $parent) { + $args{parent} = find_or_create_isa_type_constraint($parent); } if(defined $name){ @@ -148,7 +145,7 @@ sub _create_type{ } } - if($TYPE{$name}){ + if(defined $TYPE{$name}){ my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__; if($this ne $that) { my $note = ''; @@ -164,20 +161,11 @@ sub _create_type{ } } } - else{ - $args{name} = '__ANON__'; - } $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); - } - else{ - $constraint = Mouse::Meta::TypeConstraint->new(%args); - } + my $constraint = Mouse::Meta::TypeConstraint->new(%args); if(defined $name){ return $TYPE{$name} = $constraint; @@ -188,16 +176,15 @@ sub _create_type{ } 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 Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it."); @@ -210,9 +197,10 @@ sub class_type { my $class = $options->{class} || $name; # ClassType - return _create_type 'subtype', $name => ( + return subtype $name => ( as => 'Object', optimized_as => Mouse::Util::generate_isa_predicate_for($class), + class => $class, ); } @@ -221,25 +209,37 @@ sub role_type { my $role = $options->{role} || $name; # RoleType - return _create_type 'subtype', $name => ( + return subtype $name => ( as => 'Object', - optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) }, + optimized_as => sub { + return Scalar::Util::blessed($_[0]) + && Mouse::Util::does_role($_[0], $role); + }, + role => $role, ); } sub duck_type { my($name, @methods); - if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){ + if(ref($_[0]) ne 'ARRAY'){ $name = shift; } @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; # DuckType - return _create_type 'subtype', $name => ( + 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, ); } @@ -250,12 +250,15 @@ sub enum { $name = shift; } - %valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); + %valid = map{ $_ => undef } + (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); # EnumType - return _create_type 'subtype', $name => ( + return _define_type 1, $name => ( as => 'Str', - optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} }, + optimized_as => sub{ + return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]}; + }, ); } @@ -370,8 +373,7 @@ sub _parse_type { sub find_type_constraint { my($spec) = @_; - return $spec if Mouse::Util::is_a_type_constraint($spec); - return undef if !defined $spec; + return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec}; @@ -382,15 +384,14 @@ sub register_type_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") + 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 undef if !defined $spec; + return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec} || do{ @@ -426,7 +427,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse =head1 VERSION -This document describes Mouse version 0.66 +This document describes Mouse version 0.76 =head2 SYNOPSIS