avoid extra FETCHes on overloaded qr stringify

/$tied/ called FETCH too many times if the FETCH returned an overloaded
object with no qr method, but with stringify fallback

diff --git a/lib/overload.t b/lib/overload.t
index 7d4dbff..d59c33d 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -1798,10 +1798,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        # note: this is testing unary qr, not binary =~
        $subs{qr} = '(qr/%s/)';
-       # XXX TODO qr overload with fallback calls "" and FETCH too often
-       #push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ];
-       push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")("")',
-                           [ 1, 2, 0,  1, 5, 0 ], 0 ];
+       push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ];
 
        $e = '"abc" ~~ (%s)';
        $subs{'~~'} = $e;

diff --git a/pp_ctl.c b/pp_ctl.c
index 527cad9..3a7f382 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -176,8 +176,9 @@ PP(pp_regcomp)
        PM_SETRE(pm, re);
     }
     else {
-       STRLEN len;
-       const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+       STRLEN len = 0;
+       const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
+
        re = PM_GETRE(pm);
        assert (re != (REGEXP*) &PL_sv_undef);
 
@@ -215,6 +216,17 @@ PP(pp_regcomp)
                const char *const p = SvPV(tmpstr, len);
                tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
            }
+           else if (SvAMAGIC(tmpstr)) {
+               /* make a copy to avoid extra stringifies */
+               SV* copy = newSV_type(SVt_PV);
+               sv_setpvn(copy, t, len);
+               if (SvUTF8(tmpstr))
+                   SvUTF8_on(copy);
+               else
+                   SvUTF8_off(copy);
+               sv_2mortal(copy);
+               tmpstr = copy;
+           }
 
                if (eng) 
                PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));