From: Ben Morrow <ben@morrow.me.uk>
Date: Tue, 27 Oct 2009 15:55:36 +0000 (+0000)
Subject: Implement the 'qr' overload type.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d4b87e753f3c5c8123aeebb4ae822cef9f2eed3c;p=p5sagit%2Fp5-mst-13.2.git

Implement the 'qr' overload type.

If this is defined, it will be called instead of stringification
whenever an object is used as a regexp or interpolated into a regexp.
This will fall back to stringification even without C<fallback => 1>,
for compatibility.

An overloaded 'qr' must return either a REGEXP or a ref to a REGEXP
(such as created by qr//). Any further overloading on the return value
will be ignored.
---

diff --git a/gv.c b/gv.c
index 22af274..3e225bc 100644
--- a/gv.c
+++ b/gv.c
@@ -1963,6 +1963,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	 case int_amg:
 	 case iter_amg:			/* XXXX Eventually should do to_gv. */
 	 case ftest_amg:		/* XXXX Eventually should do to_gv. */
+	 case regexp_amg:
 	     /* FAIL safe */
 	     return NULL;	/* Delegate operation to standard mechanisms. */
 	     break;
diff --git a/lib/overload.t b/lib/overload.t
index 1f9bc1b..80b4f13 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" }	# Not needed, additional overhead
 package main;
 
 $| = 1;
-use Test::More tests => 577;
+use Test::More tests => 598;
 
 
 $a = new Oscalar "087";
@@ -1182,6 +1182,84 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 }
 
 {
+    {
+        package QRonly;
+        use overload qr => sub { qr/x/ }, fallback => 1;
+    }
+    {
+        my $x = bless [], "QRonly";
+
+        # like tries to be too clever, and decides that $x-stringified
+        # doesn't look like a regex
+        ok("x" =~ $x, "qr-only matches");
+        ok("xx" =~ /x$x/, "qr-only matches with concat");
+        like("$x", qr/QRonly=ARRAY/, "qr-only doesn't have string overload");
+
+        my $qr = bless qr/y/, "QRonly";
+        ok("x" =~ $qr, "qr with qr-overload uses overload");
+        is("$qr", "".qr/y/, "qr with qr-overload stringify");
+
+        my $rx = $$qr;
+        ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match");
+        is("$rx", "".qr/y/, "bare rx with qr-overload stringify");
+    }
+    {
+        package QRandSTR;
+        use overload qr => sub { qr/x/ }, q/""/ => sub { "y" };
+    }
+    {
+        my $x = bless [], "QRandSTR";
+        ok("x" =~ $x, "qr+str uses qr for match");
+        ok("xx" =~ /x$x/, "qr+str uses qr for match with concat");
+        is("$x", "y", "qr+str uses str for stringify");
+
+        my $qr = bless qr/z/, "QRandSTR";
+        is("$qr", "y", "qr with qr+str uses str for stringify");
+        ok("xx" =~ /x$x/, "qr with qr+str uses qr for match");
+
+        my $rx = $$qr;
+        ok("z" =~ $rx, "bare rx with qr+str doesn't overload match");
+        is("$rx", "".qr/z/, "bare rx with qr+str doesn't overload stringify");
+    }
+    {
+        package QRany;
+        use overload qr => sub { $_[0]->(@_) };
+
+        package QRself;
+        use overload qr => sub { $_[0] };
+    }
+    {
+        my $rx = bless sub { ${ qr/x/ } }, "QRany";
+        ok(eval { "x" =~ $rx }, "qr overload accepts a bare rx");
+
+        my $str = bless sub { "x" }, "QRany";
+        ok(!eval { "x" =~ $str }, "qr overload doesn't accept a string");
+        like($@, qr/^qr overload did not return a REGEXP/, "correct error");
+
+        my $oqr = bless qr/z/, "QRandSTR";
+        my $oqro = bless sub { $oqr }, "QRany";
+        ok(eval { "z" =~ $oqro }, "qr overload doesn't recurse");
+
+        my $qrs = bless qr/z/, "QRself";
+        ok(eval { "z" =~ $qrs }, "qr overload can return self");
+    }
+    {
+        package STRonly;
+        use overload q/""/ => sub { "x" };
+
+        package STRonlyFB;
+        use overload q/""/ => sub { "x" }, fallback => 1;
+    }
+    {
+        my $fb = bless [], "STRonlyFB";
+        ok(eval { "x" =~ $fb }, "qr falls back to \"\"");
+
+        my $nofb = bless [], "STRonly";
+        ok(eval { "x" =~ $nofb }, "qr falls back even without fallback");
+    }
+}
+
+{
     my $twenty_three = 23;
     # Check that constant overloading propagates into evals
     BEGIN { overload::constant integer => sub { 23 } }
diff --git a/pp_ctl.c b/pp_ctl.c
index f314989..ce60ea0 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -93,34 +93,61 @@ PP(pp_regcomp)
 	RETURN;
     }
 #endif
+
+#define tryAMAGICregexp(rx)			\
+    STMT_START {				\
+	if (SvROK(rx) && SvAMAGIC(rx)) {	\
+	    SV *sv = AMG_CALLun(rx, regexp);	\
+	    if (sv) {				\
+		if (SvROK(sv))			\
+		    sv = SvRV(sv);		\
+		if (SvTYPE(sv) != SVt_REGEXP)	\
+		    Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
+		rx = sv;			\
+	    }					\
+	}					\
+    } STMT_END
+	    
+
     if (PL_op->op_flags & OPf_STACKED) {
 	/* multiple args; concatentate them */
 	dMARK; dORIGMARK;
 	tmpstr = PAD_SV(ARGTARG);
 	sv_setpvs(tmpstr, "");
 	while (++MARK <= SP) {
+	    SV *msv = *MARK;
 	    if (PL_amagic_generation) {
 		SV *sv;
-		if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
-		    (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+
+		tryAMAGICregexp(msv);
+
+		if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+		    (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
 		{
 		   sv_setsv(tmpstr, sv);
 		   continue;
 		}
 	    }
-	    sv_catsv(tmpstr, *MARK);
+	    sv_catsv(tmpstr, msv);
 	}
     	SvSETMAGIC(tmpstr);
 	SP = ORIGMARK;
     }
-    else
+    else {
 	tmpstr = POPs;
+	tryAMAGICregexp(tmpstr);
+    }
+
+#undef tryAMAGICregexp
 
     if (SvROK(tmpstr)) {
 	SV * const sv = SvRV(tmpstr);
 	if (SvTYPE(sv) == SVt_REGEXP)
 	    re = (REGEXP*) sv;
     }
+    else if (SvTYPE(tmpstr) == SVt_REGEXP)
+	re = (REGEXP*) tmpstr;
+
     if (re) {
 	re = reg_temp_copy(NULL, re);
 	ReREFCNT_dec(PM_GETRE(pm));