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.
---
Moose.xs | 30 ++++++++++++++++++++
lib/Moose/Util/TypeConstraints.pm | 6 +--
.../Util/TypeConstraints/OptimizedConstraints.pm | 4 +-
.../003_util_std_type_constraints.t | 3 +-
4 files changed, 36 insertions(+), 7 deletions(-)
diff --git a/Moose.xs b/Moose.xs
index 874e9e0..fbab473 100644
--- a/Moose.xs
+++ b/Moose.xs
@@ -85,6 +85,26 @@ 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//.
+#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
+
MODULE = Moose PACKAGE = Moose::Exporter
void
@@ -100,3 +120,13 @@ _export_is_flagged (SV *sv)
RETVAL = export_flag_is_set(aTHX_ sv);
OUTPUT:
RETVAL
+
+MODULE = Moose PACKAGE = Moose::Util
+
+SV*
+_is_regexp (SV *sv)
+ PROTOTYPE: $
+ CODE:
+ RETVAL = SvRXOK(sv) ? &PL_sv_yes : &PL_sv_no;
+ OUTPUT:
+ RETVAL
diff --git a/lib/Moose/Util/TypeConstraints.pm
b/lib/Moose/Util/TypeConstraints.pm
index 1f66409..bf3fc5c 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -731,7 +731,7 @@ 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' } =>
+subtype 'RegexpRef' => as 'Ref' => where { Moose::Util::_is_regexp($_) } =>
optimize_as
\&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
@@ -745,10 +745,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 5d54359..4de2eca 100644
--- a/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm
@@ -36,12 +36,12 @@ 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 RegexpRef { Moose::Util::_is_regexp($_[0]) }
sub GlobRef { ref($_[0]) eq 'GLOB' }
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/040_type_constraints/003_util_std_type_constraints.t
b/t/040_type_constraints/003_util_std_type_constraints.t
index 20c0f54..75a818c 100644
--- a/t/040_type_constraints/003_util_std_type_constraints.t
+++ b/t/040_type_constraints/003_util_std_type_constraints.t
@@ -256,6 +256,7 @@ ok(!defined RegexpRef($GLOB_REF), '... RegexpRef
rejects anything which i
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 {}, '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');
@@ -301,7 +302,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');
--
1.7.3.3
