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 (file)
--- 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 (file)
--- 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 (file)
--- 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));