X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=d81d5d021b19df137e1b659a24441c535958a35e;hb=c91d12e031bd905978b1e664df94fc41bc647d34;hp=812ecd65ae58aba13a3d19732dfac31e79d3653d;hpb=3b46bd4991dea7ead4e7f52a089222d24554e2bd;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 812ecd6..d81d5d0 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -1,45 +1,32 @@ package Mouse::Util::TypeConstraints; use strict; use warnings; +use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; -my %SUBTYPE; +our @EXPORT = qw( + as where message from via type subtype coerce class_type role_type enum +); + +my %TYPE; +my %TYPE_SOURCE; my %COERCE; my %COERCE_KEYS; -#find_type_constraint register_type_constraint -sub import { - my $class = shift; - my %args = @_; - my $caller = $args{callee} || caller(0); - - no strict 'refs'; - *{"$caller\::as"} = \&_as; - *{"$caller\::where"} = \&_where; - *{"$caller\::message"} = \&_message; - *{"$caller\::from"} = \&_from; - *{"$caller\::via"} = \&_via; - *{"$caller\::subtype"} = \&_subtype; - *{"$caller\::coerce"} = \&_coerce; - *{"$caller\::class_type"} = \&_class_type; - *{"$caller\::role_type"} = \&_role_type; -} - - -sub _as ($) { +sub as ($) { as => $_[0] } -sub _where (&) { +sub where (&) { where => $_[0] } -sub _message ($) { +sub message (&) { message => $_[0] } -sub _from { @_ } -sub _via (&) { +sub from { @_ } +sub via (&) { $_[0] } @@ -47,64 +34,85 @@ my $optimized_constraints; my $optimized_constraints_base; { no warnings 'uninitialized'; - %SUBTYPE = ( + %TYPE = ( Any => sub { 1 }, Item => sub { 1 }, Bool => sub { - !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' + !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0' }, - Undef => sub { !defined($_) }, - Defined => sub { defined($_) }, - Value => sub { defined($_) && !ref($_) }, - Num => sub { !ref($_) && looks_like_number($_) }, - Int => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ }, - Str => sub { defined($_) && !ref($_) }, - ClassName => sub { Mouse::is_class_loaded($_) }, - Ref => sub { ref($_) }, - - ScalarRef => sub { ref($_) eq 'SCALAR' }, - ArrayRef => sub { ref($_) eq 'ARRAY' }, - HashRef => sub { ref($_) eq 'HASH' }, - CodeRef => sub { ref($_) eq 'CODE' }, - RegexpRef => sub { ref($_) eq 'Regexp' }, - GlobRef => sub { ref($_) eq 'GLOB' }, + 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]) }, + ClassName => sub { Mouse::is_class_loaded($_[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($_) eq 'GLOB' - && openhandle($_) + ref($_[0]) eq 'GLOB' && openhandle($_[0]) or - blessed($_) - && $_->isa("IO::Handle") - }, + blessed($_[0]) && $_[0]->isa("IO::Handle") + }, - Object => sub { blessed($_) && blessed($_) ne 'Regexp' }, + Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, ); - sub optimized_constraints { \%SUBTYPE } - my @SUBTYPE_KEYS = keys %SUBTYPE; - sub list_all_builtin_type_constraints { @SUBTYPE_KEYS } + 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; +} + +sub type { + my $pkg = caller(0); + my($name, %conf) = @_; + 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 { $TYPE{delete $conf{as} || 'Any' } }; + + $TYPE_SOURCE{$name} = $pkg; + $TYPE{$name} = sub { local $_=$_[0]; $constraint->($_) }; } -sub _subtype { +sub subtype { my $pkg = caller(0); my($name, %conf) = @_; - if (my $type = $SUBTYPE{$name}) { - Carp::croak "The type constraint '$name' has already been created, cannot be created again in $pkg"; + 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 $stuff = $conf{where} || do { $SUBTYPE{delete $conf{as} || 'Any' } }; - my $as = $conf{as} || ''; - if ($as = $SUBTYPE{$as}) { - $SUBTYPE{$name} = sub { $as->($_) && $stuff->($_) }; + my $constraint = $conf{where} || do { + my $as = delete $conf{as} || 'Any'; + if (! exists $TYPE{$as}) { # Perhaps it's a parameterized source? + Mouse::Meta::Attribute::_build_type_constraint($as); + } + $TYPE{$as}; + }; + my $as = $conf{as} || ''; + + $TYPE_SOURCE{$name} = $pkg; + + if ($as = $TYPE{$as}) { + $TYPE{$name} = sub { local $_=$_[0]; $as->($_) && $constraint->($_) }; } else { - $SUBTYPE{$name} = $stuff; + $TYPE{$name} = sub { local $_=$_[0]; $constraint->($_) }; } } -sub _coerce { +sub coerce { my($name, %conf) = @_; Carp::croak "Cannot find type '$name', perhaps you forgot to load it." - unless $SUBTYPE{$name}; + unless $TYPE{$name}; unless ($COERCE{$name}) { $COERCE{$name} = {}; @@ -114,28 +122,33 @@ sub _coerce { Carp::croak "A coercion action already exists for '$type'" if $COERCE{$name}->{$type}; - Carp::croak "Could not find the type constraint ($type) to coerce from" - unless $SUBTYPE{$type}; + if (! $TYPE{$type}) { + # looks parameterized + if ($type =~ /^[^\[]+\[.+\]$/) { + Mouse::Meta::Attribute::_build_type_constraint($type); + } else { + Carp::croak "Could not find the type constraint ($type) to coerce from" + } + } push @{ $COERCE_KEYS{$name} }, $type; $COERCE{$name}->{$type} = $code; } } -sub _class_type { +sub class_type { my $pkg = caller(0); my($name, $conf) = @_; my $class = $conf->{class}; - Mouse::load_class($class); - _subtype( + subtype( $name => where => sub { $_->isa($class) } ); } -sub _role_type { +sub role_type { my($name, $conf) = @_; my $role = $conf->{role}; - _subtype( + subtype( $name => where => sub { return unless defined $_ && ref($_) && $_->isa('Mouse::Object'); $_->meta->does_role($role); @@ -151,15 +164,36 @@ sub typecast_constraints { next unless $COERCE{$type}; for my $coerce_type (@{ $COERCE_KEYS{$type}}) { $_ = $value; - next unless $SUBTYPE{$coerce_type}->(); + next unless $TYPE{$coerce_type}->($value); $_ = $value; - $_ = $COERCE{$type}->{$coerce_type}->(); - return $_ if $type_constraint->(); + $_ = $COERCE{$type}->{$coerce_type}->($value); + return $_ if $type_constraint->($_); } } return $value; } +my $serial_enum = 0; +sub enum { + # enum ['small', 'medium', 'large'] + if (ref($_[0]) eq 'ARRAY') { + my @elements = @{ shift @_ }; + + my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::' + . ++$serial_enum; + enum($name, @elements); + return $name; + } + + # enum size => 'small', 'medium', 'large' + my $name = shift; + my %is_valid = map { $_ => 1 } @_; + + subtype( + $name => where => sub { $is_valid{$_} } + ); +} + 1; __END__ @@ -174,6 +208,22 @@ Mouse::Util::TypeConstraints - simple type constraints Returns the simple type constraints that Mouse understands. +=head1 FUNCTIONS + +=over 4 + +=item B as 'Parent' => where { } ...> + +=item B where { } ...> + +=item B + +=item B + +=item B + +=back + =cut