X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FTypeRegistry.pm;h=09c38e80e7fd9da8d3145cc409d4c866850186bf;hb=deb956b335075f0bd0c41be54c01e5ac309592f1;hp=ecde30d9b0324eb9b931e406e8f0560a42dc1be2;hpb=26eaf09a9d4d6558ca4ee08a803728887ddf9b8a;p=gitmo%2FMouse.git diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm index ecde30d..09c38e8 100644 --- a/lib/Mouse/TypeRegistry.pm +++ b/lib/Mouse/TypeRegistry.pm @@ -1,128 +1,21 @@ -#!/usr/bin/env perl package Mouse::TypeRegistry; -use strict; -use warnings; - -use Mouse::Util qw/blessed looks_like_number openhandle/; - -my $SUBTYPE = +{}; -my $COERCE = +{}; +use Mouse::Util::TypeConstraints; sub import { - my $class = shift; - my %args = @_; - my $caller = caller(0); - - $SUBTYPE->{$caller} ||= +{}; - $COERCE->{$caller} ||= +{}; - - if (defined $args{'-export'} && ref($args{'-export'}) eq 'ARRAY') { - no strict 'refs'; - *{"$caller\::import"} = sub { _import(@_) }; - } - - no strict 'refs'; - *{"$caller\::subtype"} = \&_subtype; - *{"$caller\::coerce"} = \&_coerce; -# *{"$caller\::class_type"} = \&_class_type; -# *{"$caller\::role_type"} = \&_role_type; -} - -sub _import { - my($class, @types) = @_; - return unless exists $SUBTYPE->{$class} && exists $COERCE->{$class}; - my $pkg = caller(1); - return unless @types; - copy_types($class, $pkg, @types); -} - -sub _subtype { - my $pkg = caller(0); - my($name, $stuff) = @_; - if (ref $stuff eq 'HASH') { - my $as = $stuff->{as}; - $stuff = optimized_constraints()->{$as}; - } - $SUBTYPE->{$pkg}->{$name} = $stuff; -} - -sub _coerce { - my $pkg = caller(0); - my($name, $conf) = @_; - $COERCE->{$pkg}->{$name} = $conf; -} + warn "Mouse::TypeRegistry is deprecated, please use Mouse::Util::TypeConstraints instead."; -sub typecast_constraints { - my($class, $pkg, $type, $value) = @_; - return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type}; - - my $optimized_constraints = optimized_constraints(); - for my $coerce_type (keys %{ $COERCE->{$pkg}->{$type} }) { - local $_ = $value; - if ($optimized_constraints->{$coerce_type}->()) { - local $_ = $value; - return $COERCE->{$pkg}->{$type}->{$coerce_type}->(); - } - } - - return $value; + shift @_; + unshift @_, 'Mouse::Util::TypeConstraints'; + goto \&Mouse::Util::TypeConstraints::import; } -{ - no warnings 'uninitialized'; - my $optimized_constraints = { - Any => sub { 1 }, - Item => sub { 1 }, - Bool => sub { - !defined($_) || $_ eq "" || "$_" eq '1' || "$_" 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' }, +sub unimport { + warn "Mouse::TypeRegistry is deprecated, please use Mouse::Util::TypeConstraints instead."; - FileHandle => sub { - ref($_) eq 'GLOB' - && openhandle($_) - or - blessed($_) - && $_->isa("IO::Handle") - }, - - Object => sub { blessed($_) && blessed($_) ne 'Regexp' }, - }; - sub optimized_constraints { - my($class, $pkg) = @_; - my $subtypes = $SUBTYPE->{$pkg} || {}; - return { %{ $subtypes }, %{ $optimized_constraints } }; - } + shift @_; + unshift @_, 'Mouse::Util::TypeConstraints'; + goto \&Mouse::Util::TypeConstraints::unimport; } 1; -__END__ - -=head1 NAME - -Mouse::TypeRegistry - simple type constraints - -=head1 METHODS - -=head2 optimized_constraints -> HashRef[CODE] - -Returns the simple type constraints that Mouse understands. - -=cut - -