overloading: make qr fallback to "" better

With the re_eval jumbo fix, the behaviour of overloaded objects in
runtime patterns, such /^$overloaded/ has changed, such that the stringify
overload ("") no longer avoids the need for 'use re "eval"': for example,

    use overload "" => sub { qr/(??{1})/ }
    my $o = bless [];
    "1" =~ /^$o/;

works in 5.16.0, but dies with "Eval-group not allowed" in blead.

Change this back to the former behaviour, such that if qr and concat
ops aren't overloaded, then use "" overloading, and if the return from
that is a qr object, extract any code blocks from it.

This is achieved by:
* moving the concat/stringify code ahead of the regex block extraction
  code,
* making the overloaded stringify call be explicit (rather than
  being invoked implicitly by sv_catsv()),
* looping to re-apply overloading to any object returned by "".
* applying those last two steps in the case of a single arg too

This is a partial fix for
[perl #113682] Bleadperl v5.17.0-424-gd24ca0c breaks
    ABIGAIL/Regexp-Common-2011121001.tar.gz

diff --git a/regcomp.c b/regcomp.c
index 79938bd..873458c 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -5383,6 +5383,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
            OP *o = NULL;
            int n = 0;
            bool utf8 = 0;
+            STRLEN orig_patlen = 0;
 
            if (pRExC_state->num_code_blocks) {
                o = cLISTOPx(expr)->op_first;
@@ -5424,11 +5425,36 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                    o = o->op_sibling;;
                }
 
+               if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
+                       (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
+               {
+                   sv_setsv(pat, sv);
+                   /* overloading involved: all bets are off over literal
+                    * code. Pretend we haven't seen it */
+                   pRExC_state->num_code_blocks -= n;
+                   n = 0;
+                    rx = NULL;
+
+               }
+               else  {
+                    while (SvAMAGIC(msv)
+                            && (sv = AMG_CALLunary(msv, string_amg))
+                            && sv != msv)
+                    {
+                        msv = sv;
+                        SvGETMAGIC(msv);
+                    }
+                    if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
+                        msv = SvRV(msv);
+                    orig_patlen = SvCUR(pat);
+                    sv_catsv_nomg(pat, msv);
+                    rx = msv;
+                    if (code)
+                        pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
+                }
+
                /* extract any code blocks within any embedded qr//'s */
-               rx = msv;
-               if (SvROK(rx))
-                   rx = SvRV(rx);
-               if (SvTYPE(rx) == SVt_REGEXP
+               if (rx && SvTYPE(rx) == SVt_REGEXP
                    && RX_ENGINE((REGEXP*)rx)->op_comp)
                {
 
@@ -5446,7 +5472,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                        pRExC_state->num_code_blocks += ri->num_code_blocks;
                        for (i=0; i < ri->num_code_blocks; i++) {
                            struct reg_code_block *src, *dst;
-                           STRLEN offset =  SvCUR(pat)
+                           STRLEN offset =  orig_patlen
                                + ((struct regexp *)SvANY(rx))->pre_prefix;
                            assert(n < pRExC_state->num_code_blocks);
                            src = &ri->code_blocks[i];
@@ -5462,29 +5488,20 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                        }
                    }
                }
-
-               if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
-                       (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
-               {
-                   sv_setsv(pat, sv);
-                   /* overloading involved: all bets are off over literal
-                    * code. Pretend we haven't seen it */
-                   pRExC_state->num_code_blocks -= n;
-                   n = 0;
-
-               }
-               else {
-                   if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
-                       msv = SvRV(msv);
-                   sv_catsv_nomg(pat, msv);
-                   if (code)
-                       pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
-               }
            }
            SvSETMAGIC(pat);
        }
-       else
+       else {
+            SV *sv;
            pat = *patternp;
+            while (SvAMAGIC(pat)
+                    && (sv = AMG_CALLunary(pat, string_amg))
+                    && sv != pat)
+            {
+                pat = sv;
+                SvGETMAGIC(pat);
+            }
+        }
 
        /* handle bare regex: foo =~ $re */
        {

diff --git a/t/re/pat.t b/t/re/pat.t
index fa9a546..0728a5a 100644 (file)
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -19,7 +19,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 438;  # Update this when adding/deleting tests.
+plan tests => 452;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1227,6 +1227,56 @@ EOP
        }
     }
 
+    #  #113682 more overloading and qr//
+    # when doing /foo$overloaded/, if $overloaded returns
+    # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval'
+    # shouldn't be required. Via '.', it still is.
+    {
+        package Qr0;
+       use overload 'qr' => sub { qr/(??{50})/ };
+
+        package Qr1;
+       use overload '""' => sub { qr/(??{51})/ };
+
+        package Qr2;
+       use overload '.'  => sub { $_[1] . qr/(??{52})/ };
+
+        package Qr3;
+       use overload '""' => sub { qr/(??{7})/ },
+                    '.'  => sub { $_[1] . qr/(??{53})/ };
+
+        package Qr_indirect;
+       use overload '""'  => sub { $_[0][0] };
+
+       package main;
+
+       for my $i (0..3) {
+           my $o = bless [], "Qr$i";
+           if ((0,0,1,1)[$i]) {
+               eval { "A5$i" =~ /^A$o$/ };
+               like($@, qr/Eval-group not allowed/, "Qr$i");
+               eval { "5$i" =~ /$o/ };
+               like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
+                       "Qr$i bare");
+               {
+                   use re 'eval';
+                   ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval");
+                   eval { "5$i" =~ /$o/ };
+                   like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
+                           "Qr$i bare - with use re eval");
+               }
+           }
+           else {
+               ok("A5$i" =~ /^A$o$/, "Qr$i");
+               ok("5$i" =~ /$o/, "Qr$i bare");
+           }
+       }
+
+       my $o = bless [ bless [], "Qr1" ], 'Qr_indirect';
+       ok("A51" =~ /^A$o/, "Qr_indirect");
+       ok("51" =~ /$o/, "Qr_indirect bare");
+    }
+
 } # End of sub run_tests
 
 1;