From: Jesse Luehrs <doy@tozt.net>
Date: Tue, 6 Jul 2010 01:32:07 +0000 (-0500)
Subject: use 5.10's new recursive regex features for the tc parser
X-Git-Tag: 1.09~66
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=68113f48ee992430ecdb99898cd99a3fea4cb196;p=gitmo%2FMoose.git

use 5.10's new recursive regex features for the tc parser
---

diff --git a/Changes b/Changes
index d0bef14..b3f0f70 100644
--- a/Changes
+++ b/Changes
@@ -15,6 +15,9 @@ for, noteworthy changes.
   * Accessors will now not be inlined if the instance metaclass isn't
     inlinable (doy).
 
+  * Use Perl 5.10's new recursive regex features, if possible, for the type
+    constraint parser (doy, nothingmuch).
+
 1.08 Tue, Jun 15, 2010
 
   [ENHANCEMENTS]
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index ff54e0a..7784a8c 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -573,20 +573,53 @@ sub _install_type_coercions ($$) {
 
     my $valid_chars = qr{[\w:\.]};
     my $type_atom   = qr{ (?>$valid_chars+) }x;
-    my $ws   = qr{ (?>\s*) }x;
-
-    my $any;
-
-    my $type = qr{  $type_atom  (?: \[ $ws (??{$any})   $ws \] )? }x;
-    my $type_capture_parts
-        = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
-    my $type_with_parameter
-        = qr{  $type_atom      \[ $ws (??{$any})   $ws \]    }x;
-
-    my $op_union = qr{ $ws \| $ws }x;
-    my $union    = qr{ $type (?> (?: $op_union $type )+ ) }x;
+    my $ws          = qr{ (?>\s*) }x;
+    my $op_union    = qr{ $ws \| $ws }x;
+
+    my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
+    if (Class::MOP::IS_RUNNING_ON_5_10) {
+        my $type_pattern
+            = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
+        my $type_capture_parts_pattern
+            = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
+        my $type_with_parameter_pattern
+            = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
+        my $union_pattern
+            = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
+        my $any_pattern
+            = q{ (?&type) | (?&union) };
+
+        my $defines = qr{(?(DEFINE)
+            (?<valid_chars>         $valid_chars)
+            (?<type_atom>           $type_atom)
+            (?<ws>                  $ws)
+            (?<op_union>            $op_union)
+            (?<type>                $type_pattern)
+            (?<type_capture_parts>  $type_capture_parts_pattern)
+            (?<type_with_parameter> $type_with_parameter_pattern)
+            (?<union>               $union_pattern)
+            (?<any>                 $any_pattern)
+        )}x;
+
+        $type                = qr{ $type_pattern                $defines }x;
+        $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
+        $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
+        $union               = qr{ $union_pattern               $defines }x;
+        $any                 = qr{ $any_pattern                 $defines }x;
+    }
+    else {
+        $type
+            = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
+        $type_capture_parts
+            = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
+        $type_with_parameter
+            = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
+        $union
+            = qr{ $type (?> (?: $op_union $type )+ ) }x;
+        $any
+            = qr{ $type | $union }x;
+    }
 
-    $any = qr{ $type | $union }x;
 
     sub _parse_parameterized_type_constraint {
         { no warnings 'void'; $any; }  # force capture of interpolated lexical