From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Tue, 17 Mar 2009 09:31:45 +0000 (+0100)
Subject: Iterative smart match over keys/elements when a coderef is on the RHS
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4a197da798f1bea5e8df6e5eb339c1552371563;p=p5sagit%2Fp5-mst-13.2.git

Iterative smart match over keys/elements when a coderef is on the RHS
---

diff --git a/pp_ctl.c b/pp_ctl.c
index db4ba16..0b172c5 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4084,22 +4084,78 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	    || (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)))
 	Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
 
-    if (SM_REF(PVCV)) {
+    if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
 	I32 c;
-	ENTER;
-	SAVETMPS;
-	PUSHMARK(SP);
-	PUSHs(Other);
-	PUTBACK;
-	c = call_sv(This, G_SCALAR);
-	SPAGAIN;
-	if (c == 0)
-	    PUSHs(&PL_sv_no);
-	else if (SvTEMP(TOPs))
-	    SvREFCNT_inc_void(TOPs);
-	FREETMPS;
-	LEAVE;
-	RETURN;
+	if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+	    /* Test sub truth for each key */
+	    HE *he;
+	    bool andedresults = TRUE;
+	    HV *hv = (HV*) SvRV(d);
+	    (void) hv_iterinit(hv);
+	    while ( (he = hv_iternext(hv)) ) {
+		ENTER;
+		SAVETMPS;
+		PUSHMARK(SP);
+		PUSHs(hv_iterkeysv(he));
+		PUTBACK;
+		c = call_sv(e, G_SCALAR);
+		SPAGAIN;
+		if (c == 0)
+		    andedresults = FALSE;
+		else
+		    andedresults = SvTRUEx(POPs) && andedresults;
+		FREETMPS;
+		LEAVE;
+	    }
+	    if (andedresults)
+		RETPUSHYES;
+	    else
+		RETPUSHNO;
+	}
+	else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+	    /* Test sub truth for each element */
+	    I32 i;
+	    bool andedresults = TRUE;
+	    AV *av = (AV*) SvRV(d);
+	    const I32 len = av_len(av);
+	    for (i = 0; i <= len; ++i) {
+		SV * const * const svp = av_fetch(av, i, FALSE);
+		ENTER;
+		SAVETMPS;
+		PUSHMARK(SP);
+		if (svp)
+		    PUSHs(*svp);
+		PUTBACK;
+		c = call_sv(e, G_SCALAR);
+		SPAGAIN;
+		if (c == 0)
+		    andedresults = FALSE;
+		else
+		    andedresults = SvTRUEx(POPs) && andedresults;
+		FREETMPS;
+		LEAVE;
+	    }
+	    if (andedresults)
+		RETPUSHYES;
+	    else
+		RETPUSHNO;
+	}
+	else {
+	    ENTER;
+	    SAVETMPS;
+	    PUSHMARK(SP);
+	    PUSHs(d);
+	    PUTBACK;
+	    c = call_sv(e, G_SCALAR);
+	    SPAGAIN;
+	    if (c == 0)
+		PUSHs(&PL_sv_no);
+	    else if (SvTEMP(TOPs))
+		SvREFCNT_inc_void(TOPs);
+	    FREETMPS;
+	    LEAVE;
+	    RETURN;
+	}
     }
     else if (SM_REF(PVHV)) {
 	if (SM_OTHER_REF(PVHV)) {
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 0097bff..7736269 100644
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -145,7 +145,7 @@ __DATA__
 =!	$ov_obj		\&foo
 =	$ov_obj		\&bar
 =	$ov_obj		sub { shift ~~ "key" }
-=!	$ov_obj		sub { shift eq "key" }
+=!	$ov_obj		sub { shift ne "key" }
 =!	$ov_obj		sub { shift ~~ "foo" }
 =	$ov_obj		%keyandmore			TODO
 =!	$ov_obj		%fooormore
@@ -181,35 +181,47 @@ __DATA__
 =@	$obj	"key"
 =@	$obj	FALSE
 
-# CODE ref against argument
-#  - arg is code ref
-!	\&foo		sub {}
-
-# - arg is not code ref
-	1	sub{shift}
-!	0	sub{shift}
-!	undef	sub{shift}
-	undef	sub{not shift}
-	FALSE	sub{not shift}
-	1	sub{scalar @_}
-	[]	\&bar
-	{}	\&bar
-	qr//	\&bar
-!	[]	\&foo
-!	{}	\&foo
-!	qr//	\&foo
-!	undef	\&foo
-	undef	\&bar
-@	undef	\&fatal
-@	1	\&fatal
-@	[]	\&fatal
-@	"foo"	\&fatal
-@	qr//	\&fatal
-# pass argument by reference
-	@fooormore	sub{scalar @_ == 1}
-	@fooormore	sub{"@_" =~ /ARRAY/}
-	%fooormore	sub{"@_" =~ /HASH/}
+# ~~ Coderef
+	sub{0}		sub { ref $_[0] eq "CODE" }
+	%fooormore	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	%fooormore	sub { $_[0] =~ /^(foo|or|less)$/ }
+	\%fooormore	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	\%fooormore	sub { $_[0] =~ /^(foo|or|less)$/ }
+	+{%fooormore}	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	+{%fooormore}	sub { $_[0] =~ /^(foo|or|less)$/ }
+	@fooormore	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	@fooormore	sub { $_[0] =~ /^(foo|or|less)$/ }
+	\@fooormore	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	\@fooormore	sub { $_[0] =~ /^(foo|or|less)$/ }
+	[@fooormore]	sub { $_[0] =~ /^(foo|or|more)$/ }
+!	[@fooormore]	sub { $_[0] =~ /^(foo|or|less)$/ }
+	%fooormore	sub{@_==1}
+	@fooormore	sub{@_==1}
+	"foo"		sub { $_[0] =~ /^(foo|or|more)$/ }
+!	"more"		sub { $_[0] =~ /^(foo|or|less)$/ }
 	/fooormore/	sub{ref $_[0] eq 'Regexp'}
+	qr/fooormore/	sub{ref $_[0] eq 'Regexp'}
+	1		sub{shift}
+!	0		sub{shift}
+!	undef		sub{shift}
+	undef		sub{not shift}
+	FALSE		sub{not shift}
+	[1]		\&bar
+	{a=>1}		\&bar
+	qr//		\&bar
+!	[1]		\&foo
+!	{a=>1}		\&foo
+# empty stuff matches, because the sub is never called:
+	[]		\&foo
+	{}		\&foo
+!	qr//		\&foo
+!	undef		\&foo
+	undef		\&bar
+@	undef		\&fatal
+@	1		\&fatal
+@	[1]		\&fatal
+@	"foo"		\&fatal
+@	qr//		\&fatal
 
 # - null-prototyped subs
 !	undef		\&FALSE