From: David Leadbeater Date: Mon, 4 Apr 2011 23:47:02 +0000 (+0100) Subject: Test RegexpRef type using SvRX or checking PERL_magic_qr X-Git-Tag: 2.0000~11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7c29582bacf33dd829d2e9c2d46bf95e92aed32f;p=gitmo%2FMoose.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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