Test RegexpRef type using SvRX or checking PERL_magic_qr

With pluggable regexp engines checking "ref" of a qr// isn't correct;
it's also possible for a normal Regex to be blessed into another
class.

Additionally an 'Object' subtype previously excluded objects that were
->isa('Regexp'), this was inconsistent with the RegexpRef handling
(i.e. neither RegexpRef nor isa => 'Regexp' would accept a subclass of
Regexp). The 'Object' subtype now simply checks if the reference is
blessed with no special logic.

diff --git a/Changes b/Changes
index 20e51ea..8ff5169 100644 (file)
--- a/Changes
+++ b/Changes
@@ -3,6 +3,13 @@ for, noteworthy changes.
 
 {{$NEXT}}
 
+  [API CHANGES]
+
+  * The RegexpRef type constraint now accepts regular expressions blessed into
+    other classes, such as those found in pluggable regexp engines.
+    Additionally the 'Object' constraint no longer rejects objects which
+    implementation is a regular expression. (David Leadbeater)
+
 1.9906-TRIAL Mon, Apr 04, 2011
 
   [OTHER]

diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm
index 9c95dd1..0e8bae5 100644 (file)
--- a/lib/Moose/Meta/TypeConstraint/Class.pm
+++ b/lib/Moose/Meta/TypeConstraint/Class.pm
@@ -30,7 +30,7 @@ sub _create_hand_optimized_type_constraint {
     my $class = $self->class;
     $self->hand_optimized_type_constraint(
         sub {
-            blessed( $_[0] ) && blessed( $_[0] ) ne 'Regexp' && $_[0]->isa($class)
+            blessed( $_[0] ) && $_[0]->isa($class)
         }
     );
 }

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index d38640b..4600592 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -727,9 +727,9 @@ subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
 
 subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
-subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
-    optimize_as
-    \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
+subtype 'RegexpRef' => as 'Ref' =>
+    where(\&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef) =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
 subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 
@@ -741,10 +741,8 @@ subtype 'FileHandle' => as 'GlobRef' => where {
 } => optimize_as
     \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 
-# NOTE:
-# blessed(qr/.../) returns true,.. how odd
 subtype 'Object' => as 'Ref' =>
-    where { blessed($_) && blessed($_) ne 'Regexp' } =>
+    where { blessed($_) } =>
     optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 
 # This type is deprecated.

diff --git a/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm b/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
index b13d8ac..c585491 100644 (file)
--- a/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
@@ -32,12 +32,13 @@ sub ScalarRef { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
 sub ArrayRef  { ref($_[0]) eq 'ARRAY'  }
 sub HashRef   { ref($_[0]) eq 'HASH'   }
 sub CodeRef   { ref($_[0]) eq 'CODE'   }
-sub RegexpRef { ref($_[0]) eq 'Regexp' }
 sub GlobRef   { ref($_[0]) eq 'GLOB'   }
 
+# RegexpRef is implemented in Moose.xs
+
 sub FileHandle { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) or blessed($_[0]) && $_[0]->isa("IO::Handle") }
 
-sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
+sub Object { blessed($_[0]) }
 
 sub Role {
     Moose::Deprecated::deprecated(

diff --git a/t/type_constraints/class_type_constraint.t b/t/type_constraints/class_type_constraint.t
index 50608c9..794e239 100644 (file)
--- a/t/type_constraints/class_type_constraint.t
+++ b/t/type_constraints/class_type_constraint.t
@@ -60,9 +60,4 @@ ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "Oink", class
 ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" );
 ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" );
 
-{
-    my $regexp_type = Moose::Meta::TypeConstraint::Class->new(name => 'Regexp', class => 'Regexp');
-    ok(!$regexp_type->check(qr//), 'a Regexp is not an instance of a class, even tho perl pretends it is');
-}
-
 done_testing;

diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t
index 2065e40..e183168 100644 (file)
--- a/t/type_constraints/util_std_type_constraints.t
+++ b/t/type_constraints/util_std_type_constraints.t
@@ -258,7 +258,9 @@ ok(!defined RegexpRef($GLOB),            '... RegexpRef rejects anything which i
 ok(!defined RegexpRef($GLOB_REF),        '... RegexpRef rejects anything which is not a RegexpRef');
 ok(!defined RegexpRef($fh),              '... RegexpRef rejects anything which is not a RegexpRef');
 ok(defined RegexpRef(qr/../),            '... RegexpRef accepts anything which is a RegexpRef');
+ok(defined RegexpRef(bless qr/../, 'Foo'), '... RegexpRef accepts anything which is a RegexpRef');
 ok(!defined RegexpRef(bless {}, 'Foo'),  '... RegexpRef rejects anything which is not a RegexpRef');
+ok(!defined RegexpRef(bless {}, 'Regexp'), '... RegexpRef rejects anything which is not a RegexpRef');
 ok(!defined RegexpRef(undef),            '... RegexpRef rejects anything which is not a RegexpRef');
 
 ok(!defined GlobRef(0),                '... GlobRef rejects anything which is not a GlobRef');
@@ -304,7 +306,7 @@ ok(!defined Object($SCALAR_REF),      '... Object rejects anything which is not
 ok(!defined Object($GLOB),            '... Object rejects anything which is not blessed');
 ok(!defined Object($GLOB_REF),        '... Object rejects anything which is not blessed');
 ok(!defined Object($fh),              '... Object rejects anything which is not blessed');
-ok(!defined Object(qr/../),           '... Object rejects anything which is not blessed');
+ok(defined Object(qr/../),           '... Object accepts anything which is blessed');
 ok(defined Object(bless {}, 'Foo'),   '... Object accepts anything which is blessed');
 ok(!defined Object(undef),             '... Object accepts anything which is blessed');
 
@@ -361,6 +363,18 @@ ok(!defined RoleName('Quux::Wibble'),  '... Rolename rejects anything which is n
 ok(!defined RoleName('Moose::Meta::TypeConstraint'),  '... RoleName accepts anything which is a RoleName');
 ok(defined RoleName('Quux::Wibble::Role'),      '... RoleName accepts anything which is a RoleName');
 
+# Test $_ is read in XS implementation
+{
+  local $_ = qr//;
+  ok(Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef(), '$_ is RegexpRef');
+  ok(!Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef(1), '$_ is not read when param provided');
+  $_ = bless qr//, "blessed";
+  ok(Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef(), '$_ is RegexpRef');
+  $_ = 42;
+  ok(!Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef(), '$_ is not RegexpRef');
+  ok(Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef(qr//), '$_ is not read when param provided');
+}
+
 close($fh) || die "Could not close the filehandle $0 for test";
 
 done_testing;

diff --git a/xs/Moose.xs b/xs/Moose.xs
index 34997f8..986498b 100644 (file)
--- a/xs/Moose.xs
+++ b/xs/Moose.xs
@@ -86,6 +86,27 @@ unset_export_flag (pTHX_ SV *sv, MAGIC *mymg)
     return 0;
 }
 
+#ifndef SvRXOK
+/* SvRXOK appeared before SVt_REGEXP did, so this implementation assumes magic
+ * based qr//. Note re::is_regexp isn't in 5.8, hence the need for this XS.
+ */
+#define SvRXOK(sv) is_regexp(aTHX_ sv)
+
+STATIC int
+is_regexp (pTHX_ SV* sv) {
+    SV* tmpsv;
+
+    if (SvMAGICAL(sv))
+        mg_get(sv);
+    if (SvROK(sv) &&
+      (tmpsv = (SV*) SvRV(sv)) &&
+      SvTYPE(tmpsv) == SVt_PVMG &&
+      (mg_find(tmpsv, PERL_MAGIC_qr)))
+        return TRUE;
+    return FALSE;
+}
+#endif
+
 EXTERN_C XS(boot_Class__MOP);
 EXTERN_C XS(boot_Class__MOP__Mixin__HasAttributes);
 EXTERN_C XS(boot_Class__MOP__Mixin__HasMethods);
@@ -128,3 +149,15 @@ _export_is_flagged (SV *sv)
         RETVAL = export_flag_is_set(aTHX_ sv);
     OUTPUT:
         RETVAL
+
+MODULE = Moose  PACKAGE = Moose::Util::TypeConstraints::OptimizedConstraints
+
+bool
+RegexpRef (SV *sv=NULL)
+    INIT:
+        if (!items)
+            sv = DEFSV;
+    CODE:
+        RETVAL = SvRXOK(sv);
+    OUTPUT:
+        RETVAL