X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=d50936b15f9f1b8c4b4abf0f5fd373eb11ca1440;hb=82750a8aa67b0f6cd139537bef64162d7a7c4d52;hp=f12c26ba9def6b74b81f1c73e573f13d4317cee5;hpb=757e07ef531d056c1543f3509c8a49a1e3d0459d;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index f12c26b..d50936b 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -9,7 +9,7 @@ use List::MoreUtils qw( all ); use Scalar::Util 'blessed'; use Moose::Exporter; -our $VERSION = '0.57'; +our $VERSION = '0.62_01'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -86,11 +86,11 @@ sub create_type_constraint_union { (scalar @type_constraint_names >= 2) || Moose->throw_error("You must pass in at least 2 type names to make a union"); - my @type_constraints = sort {$a->name cmp $b->name} map { + my @type_constraints = map { find_or_parse_type_constraint($_) || Moose->throw_error("Could not locate type constraint ($_) for the union"); } @type_constraint_names; - + return Moose::Meta::TypeConstraint::Union->new( type_constraints => \@type_constraints ); @@ -107,7 +107,7 @@ sub create_parameterized_type_constraint { my $base_type_tc = $REGISTRY->get_type_constraint($base_type); return _create_parameterized_type_constraint( $base_type_tc, - $type_parameter, + $type_parameter ); } else { Moose->throw_error("Could not locate the base type ($base_type)"); @@ -118,16 +118,14 @@ sub _create_parameterized_type_constraint { my ( $base_type_tc, $type_parameter ) = @_; if ( $base_type_tc->can('parameterize') ) { return $base_type_tc->parameterize($type_parameter); - } - else { + } else { return Moose::Meta::TypeConstraint::Parameterized->new( - name => $base_type_tc->name . '[' . $type_parameter . ']', + name => $base_type_tc->name . '[' . $type_parameter . ']', parent => $base_type_tc, - type_parameter => - find_or_create_isa_type_constraint($type_parameter), + type_parameter => find_or_create_isa_type_constraint($type_parameter), ); } -} +} #should we also support optimized checks? sub create_class_type_constraint { @@ -223,7 +221,7 @@ sub find_or_parse_type_constraint { } sub normalize_type_constraint_name { - my $type_constraint_name = shift @_; + my $type_constraint_name = shift; $type_constraint_name =~ s/\s//g; return $type_constraint_name; } @@ -356,15 +354,15 @@ sub _create_type_constraint ($$$;$$) { my $parent = shift; my $check = shift; - my ($message, $optimized); + my ( $message, $optimized ); for (@_) { $message = $_->{message} if exists $_->{message}; $optimized = $_->{optimized} if exists $_->{optimized}; } - my $pkg_defined_in = scalar(caller(0)); + my $pkg_defined_in = scalar( caller(0) ); - if (defined $name) { + if ( defined $name ) { my $type = $REGISTRY->get_type_constraint($name); ( $type->_package_defined_in eq $pkg_defined_in ) @@ -376,37 +374,24 @@ sub _create_type_constraint ($$$;$$) { if defined $type; } - my $class = "Moose::Meta::TypeConstraint"; - - # FIXME should probably not be a special case - if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) { - $class = "Moose::Meta::TypeConstraint::Parameterizable" - if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable"); - } - - my $constraint = $class->new( - name => $name || '__ANON__', + my %opts = ( + name => $name, package_defined_in => $pkg_defined_in, - ($parent ? (parent => $parent ) : ()), - ($check ? (constraint => $check) : ()), - ($message ? (message => $message) : ()), - ($optimized ? (optimized => $optimized) : ()), + ( $check ? ( constraint => $check ) : () ), + ( $message ? ( message => $message ) : () ), + ( $optimized ? ( optimized => $optimized ) : () ), ); - # NOTE: - # if we have a type constraint union, and no - # type check, this means we are just aliasing - # the union constraint, which means we need to - # handle this differently. - # - SL - if (not(defined $check) - && $parent->isa('Moose::Meta::TypeConstraint::Union') - && $parent->has_coercion - ){ - $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( - type_constraint => $parent - )); + my $constraint; + if ( defined $parent + and $parent + = blessed $parent ? $parent : find_or_parse_type_constraint($parent) ) + { + $constraint = $parent->create_child_type(%opts); + } + else { + $constraint = Moose::Meta::TypeConstraint->new(%opts); } $REGISTRY->add_type_constraint($constraint) @@ -457,19 +442,12 @@ sub _install_type_coercions ($$) { my $op_union = qr{ \s* \| \s* }x; my $union = qr{ $type (?: $op_union $type )+ }x; - ## New Stuff for structured types. - my $comma = qr{,}; - my $indirection = qr{=>}; - my $divider_ops = qr{ $comma | $indirection }x; - my $structure_divider = qr{\s* $divider_ops \s*}x; - my $structure_elements = qr{ ($type $structure_divider*)+ }x; - - $any = qr{ $type | $union | $structure_elements }x; + $any = qr{ $type | $union }x; sub _parse_parameterized_type_constraint { { no warnings 'void'; $any; } # force capture of interpolated lexical - my($base, $elements) = ($_[0] =~ m{ $type_capture_parts }x); - return ($base,$elements); + $_[0] =~ m{ $type_capture_parts }x; + return ($1, $2); } sub _detect_parameterized_type_constraint { @@ -503,6 +481,27 @@ sub _install_type_coercions ($$) { # define some basic built-in types ## -------------------------------------------------------- +# By making these classes immutable before creating all the types we +# below, we avoid repeatedly calling the slow MOP-based accessors. +$_->make_immutable( + inline_constructor => 1, + constructor_name => "_new", + + # these are Class::MOP accessors, so they need inlining + inline_accessors => 1 + ) for grep { $_->is_mutable } + map { $_->meta } + qw( + Moose::Meta::TypeConstraint + Moose::Meta::TypeConstraint::Union + Moose::Meta::TypeConstraint::Parameterized + Moose::Meta::TypeConstraint::Parameterizable + Moose::Meta::TypeConstraint::Class + Moose::Meta::TypeConstraint::Role + Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::Registry +); + type 'Any' => where { 1 }; # meta-type including all type 'Item' => where { 1 }; # base-type @@ -981,7 +980,7 @@ C. =item B -Attempts to parse the type name using L and if +Attempts to parse the type name using C and if no appropriate constraint is found will create a new anonymous one. The C variant will use C and the C