From: Rafael Garcia-Suarez Date: Fri, 6 Mar 2009 14:57:21 +0000 (+0100) Subject: Remove special case for coderefs with empty prototypes in smart match X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=84c82fbf774aa7c5e123c96735477b275c79761c;p=p5sagit%2Fp5-mst-13.2.git Remove special case for coderefs with empty prototypes in smart match (plus, fix a metasyntactic name clash in the switch test) --- diff --git a/pp_ctl.c b/pp_ctl.c index f512832..33ac1ee 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -4029,18 +4029,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV *This, *Other; /* 'This' (and Other to match) to play with C++ */ REGEXP *this_regex, *other_regex; -# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0) - # define SM_REF(type) ( \ (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \ || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d))) -# define SM_CV_NEP /* Find a code ref without an empty prototype */ \ - ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \ - && NOT_EMPTY_PROTO(This) && (Other = e)) \ - || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \ - && NOT_EMPTY_PROTO(This) && (Other = d))) - # define SM_REGEX ( \ (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \ && (this_regex = (REGEXP*) This) \ @@ -4094,17 +4086,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); } - if (SM_CV_NEP) { + if (SM_REF(PVCV)) { I32 c; - - if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) ) - { - if (This == SvRV(Other)) - RETPUSHYES; - else - RETPUSHNO; - } - ENTER; SAVETMPS; PUSHMARK(SP); @@ -4338,42 +4321,6 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) destroy_matcher(matcher); RETURN; } - else if (SM_REF(PVCV)) { - I32 c; - /* This must be a null-prototyped sub, because we - already checked for the other kind. */ - - ENTER; - SAVETMPS; - PUSHMARK(SP); - PUTBACK; - c = call_sv(This, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - - if (SM_OTHER_REF(PVCV)) { - /* This one has to be null-proto'd too. - Call both of 'em, and compare the results */ - PUSHMARK(SP); - c = call_sv(SvRV(Other), G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE; - PUTBACK; - return pp_eq(); - } - - FREETMPS; - LEAVE; - RETURN; - } else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e)) || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) ) { diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t index fcacd76..685216d 100644 --- a/t/op/smartmatch.t +++ b/t/op/smartmatch.t @@ -157,12 +157,7 @@ __DATA__ # CODE ref against argument # - arg is code ref - \&foo \&foo ! \&foo sub {} -! \&foo sub { "$_[0]" =~ /^CODE/ } -! \&foo \&bar - \&fatal \&fatal -! \&foo \&fatal # - arg is not code ref 1 sub{shift} @@ -194,25 +189,15 @@ __DATA__ a_const "a constant" a_const a_const a_const b_const - \&a_const \&a_const -! \&a_const \&b_const ! undef \&FALSE undef \&TRUE ! 0 \&FALSE 0 \&TRUE ! 1 \&FALSE 1 \&TRUE - \&FALSE \&FALSE ! \&FALSE \&foo -! \&FALSE \&bar -! \&TRUE \&foo -! \&TRUE \&bar -! \&TWO \&foo -! \&TWO \&bar - \&FALSE \&FALSE # - non-null-prototyped subs -! \&bar \&gorch bar gorch @ fatal bar diff --git a/t/op/switch.t b/t/op/switch.t index e01ce2f..b00ade8 100644 --- a/t/op/switch.t +++ b/t/op/switch.t @@ -428,11 +428,11 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") } } # Sub and method calls -sub bar {"bar"} +sub notfoo {"bar"} { my $ok = 0; given("foo") { - when(bar()) {$ok = 1} + when(notfoo()) {$ok = 1} } ok($ok, "Sub call acts as boolean") } @@ -440,7 +440,7 @@ sub bar {"bar"} { my $ok = 0; given("foo") { - when(main->bar()) {$ok = 1} + when(main->notfoo()) {$ok = 1} } ok($ok, "Class-method call acts as boolean") } @@ -449,7 +449,7 @@ sub bar {"bar"} my $ok = 0; my $obj = bless []; given("foo") { - when($obj->bar()) {$ok = 1} + when($obj->notfoo()) {$ok = 1} } ok($ok, "Object-method call acts as boolean") } @@ -721,18 +721,18 @@ my $f = tie my $v, "FetchCounter"; { no warnings "redefine"; my $called_foo = 0; - sub foo {$called_foo = 1} + sub foo {$called_foo = 1; "@_" eq "foo"} my $called_bar = 0; - sub bar {$called_bar = 1} + sub bar {$called_bar = 1; "@_" eq "bar"} my ($matched_foo, $matched_bar) = (0, 0); - given(\&foo) { + given("foo") { when(\&bar) {$matched_bar = 1} when(\&foo) {$matched_foo = 1} } - is($called_foo, 0, "Code ref comparison: foo not called"); - is($called_bar, 0, "Code ref comparison: bar not called"); - is($matched_bar, 0, "Code ref didn't match different one"); - is($matched_foo, 1, "Code ref did match itself"); + is($called_foo, 1, "foo() was called"); + is($called_bar, 1, "bar() was called"); + is($matched_bar, 0, "bar didn't match"); + is($matched_foo, 1, "foo did match"); } sub contains_x {