X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=f84b57e8c53f8689131b83a745f87e059cffbfa6;hb=f5bc97e5bbde4f29f52d85ac7c03251665dfd52b;hp=9a16eacf6d777fa70da677ef71115be39c597020;hpb=e3979c3e3cf061a660e1ed3447da812d45962aa2;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 9a16eac..f84b57e 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.60';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -20,31 +20,11 @@ our $AUTHORITY = 'cpan:STEVAN';
 # ensures the prototypes are in scope when consumers are
 # compiled.
 
-# creation and location
-sub find_type_constraint                 ($);
-sub register_type_constraint             ($);
-sub find_or_create_type_constraint       ($;$);
-sub find_or_parse_type_constraint        ($);
-sub find_or_create_isa_type_constraint   ($);
-sub find_or_create_does_type_constraint  ($);
-sub create_type_constraint_union         (@);
-sub create_parameterized_type_constraint ($);
-sub create_class_type_constraint         ($;$);
-sub create_role_type_constraint          ($;$);
-sub create_enum_type_constraint          ($$);
-
 # dah sugah!
-sub type        ($$;$$);
-sub subtype     ($$;$$$);
-sub class_type  ($;$);
-sub coerce      ($@);
-sub as          ($);
-sub from        ($);
 sub where       (&);
 sub via         (&);
 sub message     (&);
 sub optimize_as (&);
-sub enum        ($;@);
 
 ## private stuff ...
 sub _create_type_constraint ($$$;$$);
@@ -93,7 +73,7 @@ sub export_type_constraints_as_functions {
     }
 }
 
-sub create_type_constraint_union (@) {
+sub create_type_constraint_union {
     my @type_constraint_names;
 
     if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
@@ -106,17 +86,17 @@ 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
     );
 }
 
-sub create_parameterized_type_constraint ($) {
+sub create_parameterized_type_constraint {
     my $type_constraint_name = shift;
     my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
 
@@ -127,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)");
@@ -138,19 +118,17 @@ 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 ($;$) {
+sub create_class_type_constraint {
     my ( $class, $options ) = @_;
 
     # too early for this check
@@ -168,7 +146,7 @@ sub create_class_type_constraint ($;$) {
     Moose::Meta::TypeConstraint::Class->new( %options );
 }
 
-sub create_role_type_constraint ($;$) {
+sub create_role_type_constraint {
     my ( $role, $options ) = @_;
 
     # too early for this check
@@ -187,7 +165,7 @@ sub create_role_type_constraint ($;$) {
 }
 
 
-sub find_or_create_type_constraint ($;$) {
+sub find_or_create_type_constraint {
     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 
     if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
@@ -214,17 +192,17 @@ sub find_or_create_type_constraint ($;$) {
     return;
 }
 
-sub find_or_create_isa_type_constraint ($) {
+sub find_or_create_isa_type_constraint {
     my $type_constraint_name = shift;
     find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
 }
 
-sub find_or_create_does_type_constraint ($) {
+sub find_or_create_does_type_constraint {
     my $type_constraint_name = shift;
     find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
 }
 
-sub find_or_parse_type_constraint ($) {
+sub find_or_parse_type_constraint {
     my $type_constraint_name = normalize_type_constraint_name(shift);
     my $constraint;
     
@@ -243,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;
 }
@@ -259,7 +237,7 @@ sub _confess {
 ## exported functions ...
 ## --------------------------------------------------------
 
-sub find_type_constraint ($) {
+sub find_type_constraint {
     my $type = shift;
 
     if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
@@ -271,7 +249,7 @@ sub find_type_constraint ($) {
     }
 }
 
-sub register_type_constraint ($) {
+sub register_type_constraint {
     my $constraint = shift;
     Moose->throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
     $REGISTRY->add_type_constraint($constraint);
@@ -280,12 +258,12 @@ sub register_type_constraint ($) {
 
 # type constructors
 
-sub type ($$;$$) {
+sub type {
     splice(@_, 1, 0, undef);
     goto &_create_type_constraint;
 }
 
-sub subtype ($$;$$$) {
+sub subtype {
     # NOTE:
     # this adds an undef for the name
     # if this is an anon-subtype:
@@ -305,7 +283,7 @@ sub subtype ($$;$$$) {
     goto &_create_type_constraint;
 }
 
-sub class_type ($;$) {
+sub class_type {
     register_type_constraint(
         create_class_type_constraint(
             $_[0],
@@ -323,20 +301,20 @@ sub role_type ($;$) {
     );
 }
 
-sub coerce ($@) {
+sub coerce {
     my ($type_name, @coercion_map) = @_;
     _install_type_coercions($type_name, \@coercion_map);
 }
 
-sub as      ($) { $_[0] }
-sub from    ($) { $_[0] }
+sub as          { @_ }
+sub from        { @_ }
 sub where   (&) { $_[0] }
 sub via     (&) { $_[0] }
 
 sub message     (&) { +{ message   => $_[0] } }
 sub optimize_as (&) { +{ optimized => $_[0] } }
 
-sub enum ($;@) {
+sub enum {
     my ($type_name, @values) = @_;
     # NOTE:
     # if only an array-ref is passed then
@@ -358,7 +336,7 @@ sub enum ($;@) {
     );
 }
 
-sub create_enum_type_constraint ($$) {
+sub create_enum_type_constraint {
     my ( $type_name, $values ) = @_;
 
     Moose::Meta::TypeConstraint::Enum->new(
@@ -376,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 )
@@ -396,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 || '__ANON__',
         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)
@@ -470,26 +435,19 @@ sub _install_type_coercions ($$) {
 
     my $any;
 
-    my $type                = qr{  $valid_chars+  (?: \[  \s* (??{$any}) \s* \] )? }x;
+    my $type                = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
     my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
-    my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any}) \s* \]    }x;
+    my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 
     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 {
@@ -771,7 +729,7 @@ that hierarchy represented visually.
 B<NOTE:> Any type followed by a type parameter C<[`a]> can be
 parameterized, this means you can say:
 
-  ArrayRef[Int]    # an array of intergers
+  ArrayRef[Int]    # an array of integers
   HashRef[CodeRef] # a hash of str to CODE ref mappings
   Maybe[Str]       # value may be a string, may be undefined