Separate handling of ${^PREMATCH} from $` etc

Currently the handling of getting the value, length etc of ${^PREMATCH}
etc is identical to that of $` etc.

Handle them separately, by adding RX_BUFF_IDX_CARET_PREMATCH etc
constants to the existing RX_BUFF_IDX_PREMATCH set.

This allows, when retrieving them, to always return undef if the current
match didn't use //p. Previously the result depended on stuff such
as whether the (non-//p) pattern included captures or not.

The documentation for ${^PREMATCH} etc states that it's only guaranteed to
return a defined value when the last pattern was //p.

As well as making things more consistent, this is a necessary
prerequisite for the following commit, which may not always copy the
whole string during a non-//p match.

diff --git a/mg.c b/mg.c
index 1f6d062..37b8125 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -913,9 +913,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        if (nextchar == '\0') {       /* ^P */
            sv_setiv(sv, (IV)PL_perldb);
        } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
-           goto do_prematch_fetch;
+
+            paren = RX_BUFF_IDX_CARET_PREMATCH;
+           goto do_numbuf_fetch;
        } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
-           goto do_postmatch_fetch;
+            paren = RX_BUFF_IDX_CARET_POSTMATCH;
+           goto do_numbuf_fetch;
        }
        break;
     case '\023':               /* ^S */
@@ -978,55 +981,46 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        break;
     case '\015': /* $^MATCH */
        if (strEQ(remaining, "ATCH")) {
+            paren = RX_BUFF_IDX_CARET_FULLMATCH;
+           goto do_numbuf_fetch;
+        }
+
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
-           if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-               /*
-                * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
-                * XXX Does the new way break anything?
-                */
-               paren = atoi(mg->mg_ptr); /* $& is in [0] */
-               CALLREG_NUMBUF_FETCH(rx,paren,sv);
-               break;
-           }
-           sv_setsv(sv,&PL_sv_undef);
-       }
+        /*
+         * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
+         * XXX Does the new way break anything?
+         */
+        paren = atoi(mg->mg_ptr); /* $& is in [0] */
+      do_numbuf_fetch:
+        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+            CALLREG_NUMBUF_FETCH(rx,paren,sv);
+            break;
+        }
+        sv_setsv(sv,&PL_sv_undef);
        break;
     case '+':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           if (RX_LASTPAREN(rx)) {
-               CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
-               break;
-           }
+           paren = RX_LASTPAREN(rx);
+           if (paren)
+                goto do_numbuf_fetch;
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '\016':               /* ^N */
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           if (RX_LASTCLOSEPAREN(rx)) {
-               CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
-               break;
-           }
-
+           paren = RX_LASTCLOSEPAREN(rx);
+           if (paren)
+                goto do_numbuf_fetch;
        }
        sv_setsv(sv,&PL_sv_undef);
        break;
     case '`':
-      do_prematch_fetch:
-       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           CALLREG_NUMBUF_FETCH(rx,-2,sv);
-           break;
-       }
-       sv_setsv(sv,&PL_sv_undef);
-       break;
+        paren = RX_BUFF_IDX_PREMATCH;
+        goto do_numbuf_fetch;
     case '\'':
-      do_postmatch_fetch:
-       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
-           CALLREG_NUMBUF_FETCH(rx,-1,sv);
-           break;
-       }
-       sv_setsv(sv,&PL_sv_undef);
-       break;
+        paren = RX_BUFF_IDX_POSTMATCH;
+        goto do_numbuf_fetch;
     case '.':
        if (GvIO(PL_last_in_gv)) {
            sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));

diff --git a/regcomp.c b/regcomp.c
index 921c0e9..1c4bad5 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -6691,37 +6691,53 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
     char *s = NULL;
     I32 i = 0;
     I32 s1, t1;
+    I32 n = paren;
 
     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
         
-    if (!rx->subbeg) {
-        sv_setsv(sv,&PL_sv_undef);
-        return;
-    } 
-    else               
-    if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
-        /* $` */
+    if ( (    n == RX_BUFF_IDX_CARET_PREMATCH
+           || n == RX_BUFF_IDX_CARET_FULLMATCH
+           || n == RX_BUFF_IDX_CARET_POSTMATCH
+         )
+         && !(rx->extflags & RXf_PMf_KEEPCOPY)
+    )
+        goto ret_undef;
+
+    if (!rx->subbeg)
+        goto ret_undef;
+
+    if (n == RX_BUFF_IDX_CARET_FULLMATCH)
+        /* no need to distinguish between them any more */
+        n = RX_BUFF_IDX_FULLMATCH;
+
+    if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
+        && rx->offs[0].start != -1)
+    {
+        /* $`, ${^PREMATCH} */
        i = rx->offs[0].start;
        s = rx->subbeg;
     }
     else 
-    if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
-        /* $' */
+    if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
+        && rx->offs[0].end != -1)
+    {
+        /* $', ${^POSTMATCH} */
        s = rx->subbeg + rx->offs[0].end;
        i = rx->sublen - rx->offs[0].end;
     } 
     else
-    if ( 0 <= paren && paren <= (I32)rx->nparens &&
-        (s1 = rx->offs[paren].start) != -1 &&
-        (t1 = rx->offs[paren].end) != -1)
+    if ( 0 <= n && n <= (I32)rx->nparens &&
+        (s1 = rx->offs[n].start) != -1 &&
+        (t1 = rx->offs[n].end) != -1)
     {
-        /* $& $1 ... */
+        /* $&, ${^MATCH},  $1 ... */
         i = t1 - s1;
         s = rx->subbeg + s1;
     } else {
-        sv_setsv(sv,&PL_sv_undef);
-        return;
+        goto ret_undef;
     }          
+
+    assert(s >= rx->subbeg);
     assert(rx->sublen >= (s - rx->subbeg) + i );
     if (i >= 0) {
         const int oldtainted = PL_tainted;
@@ -6757,6 +6773,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
                 SvTAINTED_off(sv);
         }
     } else {
+      ret_undef:
         sv_setsv(sv,&PL_sv_undef);
         return;
     }
@@ -6783,13 +6800,18 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
     struct regexp *const rx = (struct regexp *)SvANY(r);
     I32 i;
     I32 s1, t1;
+    I32 n = paren;
 
     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
 
     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
-       switch (paren) {
-      /* $` / ${^PREMATCH} */
-      case RX_BUFF_IDX_PREMATCH:
+    switch (paren) {
+      case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
+         if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+            goto warn_undef;
+        /*FALLTHROUGH*/
+
+      case RX_BUFF_IDX_PREMATCH:       /* $` */
         if (rx->offs[0].start != -1) {
                        i = rx->offs[0].start;
                        if (i > 0) {
@@ -6799,8 +6821,11 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
                        }
            }
         return 0;
-      /* $' / ${^POSTMATCH} */
-      case RX_BUFF_IDX_POSTMATCH:
+
+      case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
+         if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+            goto warn_undef;
+      case RX_BUFF_IDX_POSTMATCH:       /* $' */
            if (rx->offs[0].end != -1) {
                        i = rx->sublen - rx->offs[0].end;
                        if (i > 0) {
@@ -6810,6 +6835,13 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
                        }
            }
         return 0;
+
+      case RX_BUFF_IDX_CARET_FULLMATCH: /* ${^MATCH} */
+         if (!(rx->extflags & RXf_PMf_KEEPCOPY))
+            goto warn_undef;
+        n = RX_BUFF_IDX_FULLMATCH;
+        /*FALLTHROUGH*/
+
       /* $& / ${^MATCH}, $1, $2, ... */
       default:
            if (paren <= (I32)rx->nparens &&
@@ -6819,6 +6851,7 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
             i = t1 - s1;
             goto getlen;
         } else {
+          warn_undef:
             if (ckWARN(WARN_UNINITIALIZED))
                 report_uninit((const SV *)sv);
             return 0;

diff --git a/regexp.h b/regexp.h
index db36edd..df3369a 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -181,9 +181,12 @@ typedef struct regexp_engine {
   paren name. >= 1 is reserved for actual numbered captures, i.e. $1,
   $2 etc.
 */
-#define RX_BUFF_IDX_PREMATCH  -2 /* $` / ${^PREMATCH}  */
-#define RX_BUFF_IDX_POSTMATCH -1 /* $' / ${^POSTMATCH} */
-#define RX_BUFF_IDX_FULLMATCH      0 /* $& / ${^MATCH}     */
+#define RX_BUFF_IDX_CARET_PREMATCH  -5 /* ${^PREMATCH}  */
+#define RX_BUFF_IDX_CARET_POSTMATCH -4 /* ${^POSTMATCH} */
+#define RX_BUFF_IDX_CARET_FULLMATCH -3 /* ${^MATCH}     */
+#define RX_BUFF_IDX_PREMATCH        -2 /* $` */
+#define RX_BUFF_IDX_POSTMATCH       -1 /* $' */
+#define RX_BUFF_IDX_FULLMATCH        0 /* $& */
 
 /*
   Flags that are passed to the named_buff and named_buff_iter

diff --git a/t/re/reg_pmod.t b/t/re/reg_pmod.t
index 301aeef..3190e03 100644 (file)
--- a/t/re/reg_pmod.t
+++ b/t/re/reg_pmod.t
@@ -11,38 +11,52 @@ use warnings;
 
 our @tests = (
     # /p      Pattern   PRE     MATCH   POST
-    [ '/p',   "456",    "123-", "456",  "-789"],
-    [ '(?p)', "456",    "123-", "456",  "-789"],
-    [ '',     "(456)",  "123-", "456",  "-789"],
-    [ '',     "456",    undef,  undef,  undef ],
+    [ '/p',   "345",    "12-", "345",  "-6789"],
+    [ '(?p)', "345",    "12-", "345",  "-6789"],
+    [ '',     "(345)",  undef,  undef,  undef ],
+    [ '',     "345",    undef,  undef,  undef ],
 );
 
-plan tests => 4 * @tests + 2;
+plan tests => 14 * @tests + 2;
 my $W = "";
 
 $SIG{__WARN__} = sub { $W.=join("",@_); };
 sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") }
 
-$_ = '123-456-789';
 foreach my $test (@tests) {
     my ($p, $pat,$l,$m,$r) = @$test;
-    my $test_name = $p eq '/p'   ? "/$pat/p"
-                  : $p eq '(?p)' ? "/(?p)$pat/"
-                  :                "/$pat/";
+    for my $sub (0,1) {
+       my $test_name = $p eq '/p'   ? "/$pat/p"
+                     : $p eq '(?p)' ? "/(?p)$pat/"
+                     :                "/$pat/";
+       $test_name = "s$test_name" if $sub;
 
-    #
-    # Cannot use if/else due to the scope invalidating ${^MATCH} and friends.
-    #
-    my $ok = ok $p eq '/p'   ? /$pat/p
-              : $p eq '(?p)' ? /(?p)$pat/
-              :                /$pat/
-              => $test_name;
-    SKIP: {
-        skip "/$pat/$p failed to match", 3
-            unless $ok;
-        is(${^PREMATCH},  $l,_u "$test_name: ^PREMATCH",$l);
-        is(${^MATCH},     $m,_u "$test_name: ^MATCH",$m );
-        is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+       #
+       # Cannot use if/else due to the scope invalidating ${^MATCH} and friends.
+       #
+       $_ = '12-345-6789';
+       my $ok =
+               $sub ?
+                       (   $p eq '/p'   ? s/$pat/abc/p
+                         : $p eq '(?p)' ? s/(?p)$pat/abc/
+                         :                s/$pat/abc/
+                       )
+                    :
+                       (   $p eq '/p'   ? /$pat/p
+                         : $p eq '(?p)' ? /(?p)$pat/
+                         :                /$pat/
+                       );
+       ok $ok, $test_name;
+       SKIP: {
+           skip "/$pat/$p failed to match", 6
+               unless $ok;
+           is(${^PREMATCH},  $l,_u "$test_name: ^PREMATCH",$l);
+           is(${^MATCH},     $m,_u "$test_name: ^MATCH",$m );
+           is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+           is(length ${^PREMATCH}, length $l, "$test_name: ^PREMATCH length");
+           is(length ${^MATCH},    length $m, "$test_name: ^MATCH length");
+           is(length ${^POSTMATCH},length $r, "$test_name: ^POSTMATCH length");
+       }
     }
 }
 is($W,"","No warnings should be produced");