This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] only copy bits of regex match string
authorDavid Mitchell <davem@iabyn.com>
Sat, 8 Sep 2012 14:42:56 +0000 (15:42 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sat, 8 Sep 2012 14:42:56 +0000 (15:42 +0100)
When making a copy of the string being matched against (so that $1, $&
et al continue to show the correct value even if the original string is
subsequently modified), only copy that substring of the original string
needed for the capture variables, rather than copying the whole string.

This is a big win for code like

    $&;
    $_ = 'x' x 1_000_000;
    1 while /(.)/;

Also, when pessimizing if the code contains $`, $& or $', record
the presence of each variable separately, so that the determination of the
substring range is based on each variable separately. So performance-wise,

   $&; /x/

is now roughly equivalent to

   /(x)/

whereas previously it was like

   /^(.*)(x)(.*)$/

and

   $&; $'; /x/

is now roughly equivalent to

   /(x)(.*)$/

etc.

Finally, this code (when not in the presence of $& etc)

    $_ = 'x' x 1_000_000;
    1 while /(.)/;

used to skip the buffer copy for performance reasons, but suffered from $1
etc changing if the original string changed. That's now been fixed too.

19 files changed:
dump.c
ext/Devel-Peek/t/Peek.t
gv.c
intrpvar.h
mg.c
perl.c
perl.h
pod/perlreapi.pod
pp.c
pp_ctl.c
pp_hot.c
regcomp.c
regexec.c
regexp.h
t/porting/known_pod_issues.dat
t/re/pat_advanced.t
t/re/pat_psycho.t
t/re/re_tests
t/re/reg_pmod.t

diff --git a/dump.c b/dump.c
index ada6ae9..46893d6 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -2056,6 +2056,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                                (UV)(r->pre_prefix));
            Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
                                (IV)(r->sublen));
+           Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
+                               (IV)(r->suboffset));
+           Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
+                               (IV)(r->subcoffset));
            if (r->subbeg)
                Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
                            PTR2UV(r->subbeg),
index 6913d59..164e2ff 100644 (file)
@@ -350,6 +350,8 @@ do_test('reference to regexp',
     GOFS = 0
     PRE_PREFIX = 4
     SUBLEN = 0
+    SUBOFFSET = 0
+    SUBCOFFSET = 0
     SUBBEG = 0x0
     ENGINE = $ADDR
     MOTHER_RE = $ADDR
diff --git a/gv.c b/gv.c
index c6e474e..e29f2fd 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1655,12 +1655,23 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
              }
              if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
-              if (*name == '[')
-               require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
-              else if (*name == '&' || *name == '`' || *name == '\'') {
-               PL_sawampersand = TRUE;
-               (void)GvSVn(gv);
-              }
+                switch (*name) {
+               case '[':
+                   require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+                    break;
+               case '`':
+                   PL_sawampersand |= SAWAMPERSAND_LEFT;
+                    (void)GvSVn(gv);
+                    break;
+               case '&':
+                   PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+                    (void)GvSVn(gv);
+                    break;
+               case '\'':
+                   PL_sawampersand |= SAWAMPERSAND_RIGHT;
+                    (void)GvSVn(gv);
+                    break;
+                }
              }
            }
            else if (len == 3 && sv_type == SVt_PVAV
@@ -1866,7 +1877,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                sv_type == SVt_PVCV ||
                sv_type == SVt_PVFM ||
                sv_type == SVt_PVIO
-               )) { PL_sawampersand = TRUE; }
+               )) { PL_sawampersand |=
+                        (*name == '`')
+                            ? SAWAMPERSAND_LEFT
+                            : (*name == '&')
+                                ? SAWAMPERSAND_MIDDLE
+                                : SAWAMPERSAND_RIGHT;
+                }
            goto magicalize;
 
        case ':':               /* $: */
index f57fa7d..94b7425 100644 (file)
@@ -292,7 +292,7 @@ The C variable which corresponds to Perl's $^W warning variable.
 */
 
 PERLVAR(I, dowarn,     U8)
-PERLVAR(I, sawampersand, bool)         /* must save all match strings */
+PERLVAR(I, sawampersand, U8)           /* must save all match strings */
 PERLVAR(I, unsafe,     bool)
 PERLVAR(I, exit_flags, U8)             /* was exit() unexpected, etc. */
 
diff --git a/mg.c b/mg.c
index 1f6d062..26cabbe 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -637,6 +637,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
     return (U32)-1;
 }
 
+/* @-, @+ */
+
 int
 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -665,7 +667,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
                    if (i > 0 && RX_MATCH_UTF8(rx)) {
                        const char * const b = RX_SUBBEG(rx);
                        if (b)
-                           i = utf8_length((U8*)b, (U8*)(b+i));
+                           i = RX_SUBCOFFSET(rx) +
+                                    utf8_length((U8*)b,
+                                        (U8*)(b-RX_SUBOFFSET(rx)+i));
                    }
 
                    sv_setiv(sv, i);
@@ -675,6 +679,8 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+/* @-, @+ */
+
 int
 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -913,9 +919,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 +987,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/perl.c b/perl.c
index 8444218..7d65719 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -860,7 +860,7 @@ perl_destruct(pTHXx)
     PL_minus_F      = FALSE;
     PL_doswitches   = FALSE;
     PL_dowarn       = G_WARN_OFF;
-    PL_sawampersand = FALSE;   /* must save all match strings */
+    PL_sawampersand = 0;       /* must save all match strings */
     PL_unsafe       = FALSE;
 
     Safefree(PL_inplace);
@@ -2343,8 +2343,9 @@ STATIC void
 S_run_body(pTHX_ I32 oldscope)
 {
     dVAR;
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
-                    PL_sawampersand ? "Enabling" : "Omitting"));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
+                    PL_sawampersand ? "Enabling" : "Omitting",
+                    (unsigned int)(PL_sawampersand)));
 
     if (!PL_restartop) {
 #ifdef PERL_MAD
diff --git a/perl.h b/perl.h
index 2cc4e91..b299432 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4854,6 +4854,12 @@ typedef enum {
 #define HINT_SORT_MERGESORT    0x00000002
 #define HINT_SORT_STABLE       0x00000100 /* sort styles (currently one) */
 
+/* flags for PL_sawampersand */
+
+#define SAWAMPERSAND_LEFT       1   /* saw $` */
+#define SAWAMPERSAND_MIDDLE     2   /* saw $& */
+#define SAWAMPERSAND_RIGHT      4   /* saw $' */
+
 /* Various states of the input record separator SV (rs) */
 #define RsSNARF(sv)   (! SvOK(sv))
 #define RsSIMPLE(sv)  (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
index 35b6b74..1ccc6d8 100644 (file)
@@ -209,7 +209,49 @@ faster than C<unpack>.
              I32 minend, SV* screamer,
              void* data, U32 flags);
 
-Execute a regexp.
+Execute a regexp. The arguments are
+
+=over 4
+
+=item rx
+
+The regular expression to execute.
+
+=item screamer
+
+This strangely-named arg is the SV to be matched against. Note that the
+actual char array to be matched against is supplied by the arguments
+described below; the SV is just used to determine UTF8ness, C<pos()> etc.
+
+=item strbeg
+
+Pointer to the physical start of the string.
+
+=item strend
+
+Pointer to the character following the physical end of the string (i.e.
+the \0).
+
+=item stringarg
+
+Pointer to the position in the string where matching should start; it might
+not be equal to C<strbeg> (for example in a later iteration of C</.../g>).
+
+=item minend
+
+Minimum length of string (measured in bytes from C<stringarg>) that must
+match; if the engine reaches the end of the match but hasn't reached this
+position in the string, it should fail.
+
+=item data
+
+Optimisation data; subject to change.
+
+=item flags
+
+Optimisation flags; subject to change.
+
+=back
 
 =head2 intuit
 
@@ -513,6 +555,8 @@ values.
         char *subbeg;  /* saved or original string so \digit works forever. */
         SV_SAVED_COPY  /* If non-NULL, SV which is COW from original */
         I32 sublen;    /* Length of string pointed by subbeg */
+       I32 suboffset;  /* byte offset of subbeg from logical start of str */
+       I32 subcoffset; /* suboffset equiv, but in chars (for @-/@+) */
 
         /* Information about the match that isn't often used */
         I32 prelen;           /* length of precomp */
@@ -653,9 +697,23 @@ occur at a floating offset from the start of the pattern. Used to do
 Fast-Boyer-Moore searches on the string to find out if its worth using
 the regex engine at all, and if so where in the string to search.
 
-=head2 C<subbeg> C<sublen> C<saved_copy>
-
-Used during execution phase for managing search and replace patterns.
+=head2 C<subbeg> C<sublen> C<saved_copy> C<suboffset> C<subcoffset>
+
+Used during the execution phase for managing search and replace patterns,
+and for providing the text for C<$&>, C<$1> etc. C<subbeg> points to a
+buffer (either the original string, or a copy in the case of
+C<RX_MATCH_COPIED(rx)>), and C<sublen> is the length of the buffer.  The
+C<RX_OFFS> start and end indices index into this buffer.
+
+In the presence of the C<REXEC_COPY_STR> flag, but with the addition of
+the C<REXEC_COPY_SKIP_PRE> or C<REXEC_COPY_SKIP_POST> flags, an engine
+can choose not to copy the full buffer (although it must still do so in
+the presence of C<RXf_PMf_KEEPCOPY> or the relevant bits being set in
+C<PL_sawampersand>). In this case, it may set C<suboffset> to indicate the
+number of bytes from the logical start of the buffer to the physical start
+(i.e. C<subbeg>). It should also set C<subcoffset>, the number of
+characters in the offset. The latter is needed to support C<@-> and C<@+>
+which work in characters, not bytes.
 
 =head2 C<wrapped> C<wraplen>
 
diff --git a/pp.c b/pp.c
index 29db8ed..e1a6c78 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5549,13 +5549,9 @@ PP(pp_split)
            if (rex_return == 0)
                break;
            TAINT_IF(RX_MATCH_TAINTED(rx));
-           if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
-               m = s;
-               s = orig;
-               orig = RX_SUBBEG(rx);
-               s = orig + (m - s);
-               strend = s + (strend - m);
-           }
+            /* we never pass the REXEC_COPY_STR flag, so it should
+             * never get copied */
+            assert(!RX_MATCH_COPIED(rx));
            m = RX_OFFS(rx)[0].start + orig;
 
            if (gimme_scalar) {
index 1477373..af0d558 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -216,9 +216,7 @@ PP(pp_substcont)
        if (CxONCE(cx) || s < orig ||
                !CALLREGEXEC(rx, s, cx->sb_strend, orig,
                             (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
-                            ((cx->sb_rflags & REXEC_COPY_STR)
-                             ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
-                             : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+                                (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
        {
            SV *targ = cx->sb_targ;
 
@@ -289,6 +287,7 @@ PP(pp_substcont)
     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
        m = s;
        s = orig;
+        assert(!RX_SUBOFFSET(rx));
        cx->sb_orig = orig = RX_SUBBEG(rx);
        s = orig + (m - s);
        cx->sb_strend = s + (cx->sb_strend - m);
@@ -353,9 +352,9 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 
     if (!p || p[1] < RX_NPARENS(rx)) {
 #ifdef PERL_OLD_COPY_ON_WRITE
-       i = 7 + RX_NPARENS(rx) * 2;
+       i = 7 + (RX_NPARENS(rx)+1) * 2;
 #else
-       i = 6 + RX_NPARENS(rx) * 2;
+       i = 6 + (RX_NPARENS(rx)+1) * 2;
 #endif
        if (!p)
            Newx(p, i, UV);
@@ -364,7 +363,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
        *rsp = (void*)p;
     }
 
-    *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
+    *p++ = RX_MATCH_COPIED(rx) ? 1 : 0;
     RX_MATCH_COPIED_off(rx);
 
 #ifdef PERL_OLD_COPY_ON_WRITE
@@ -373,9 +372,10 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 #endif
 
     *p++ = RX_NPARENS(rx);
-
     *p++ = PTR2UV(RX_SUBBEG(rx));
     *p++ = (UV)RX_SUBLEN(rx);
+    *p++ = (UV)RX_SUBOFFSET(rx);
+    *p++ = (UV)RX_SUBCOFFSET(rx);
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
        *p++ = (UV)RX_OFFS(rx)[i].start;
        *p++ = (UV)RX_OFFS(rx)[i].end;
@@ -403,9 +403,10 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 #endif
 
     RX_NPARENS(rx) = *p++;
-
     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
     RX_SUBLEN(rx) = (I32)(*p++);
+    RX_SUBOFFSET(rx) = (I32)*p++;
+    RX_SUBCOFFSET(rx) = (I32)*p++;
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
        RX_OFFS(rx)[i].start = (I32)(*p++);
        RX_OFFS(rx)[i].end = (I32)(*p++);
index 6c3f4f6..0d70dfc 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1319,15 +1319,18 @@ PP(pp_match)
            }
        }
     }
-    /* XXX: comment out !global get safe $1 vars after a
-       match, BUT be aware that this leads to dramatic slowdowns on
-       /g matches against large strings.  So far a solution to this problem
-       appears to be quite tricky.
-       Test for the unsafe vars are TODO for now. */
-    if (       (!global && RX_NPARENS(rx))
-           || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
-           || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
-       r_flags |= REXEC_COPY_STR;
+    if (       RX_NPARENS(rx)
+            || PL_sawampersand
+            || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+    ) {
+       r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
+        /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
+         * only on the first iteration. Therefore we need to copy $' as well
+         * as $&, to make the rest of the string available for captures in
+         * subsequent iterations */
+        if (! (global && gimme == G_ARRAY))
+            r_flags |= REXEC_COPY_SKIP_POST;
+    };
 
   play_it_again:
     if (global && RX_OFFS(rx)[0].start != -1) {
@@ -1472,6 +1475,8 @@ yup:                                      /* Confirmed by INTUIT */
     if (global) {
        /* FIXME - should rx->subbeg be const char *?  */
        RX_SUBBEG(rx) = (char *) truebase;
+       RX_SUBOFFSET(rx) = 0;
+       RX_SUBCOFFSET(rx) = 0;
        RX_OFFS(rx)[0].start = s - truebase;
        if (RX_MATCH_UTF8(rx)) {
            char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
@@ -1507,6 +1512,8 @@ yup:                                      /* Confirmed by INTUIT */
 #endif
        }
        RX_SUBLEN(rx) = strend - t;
+       RX_SUBOFFSET(rx) = 0;
+       RX_SUBCOFFSET(rx) = 0;
        RX_MATCH_COPIED_on(rx);
        off = RX_OFFS(rx)[0].start = s - t;
        RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
@@ -2127,9 +2134,13 @@ PP(pp_subst)
        pm = PL_curpm;
        rx = PM_GETRE(pm);
     }
-    r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
-           || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
-              ? REXEC_COPY_STR : 0;
+
+    r_flags = (    RX_NPARENS(rx)
+                || PL_sawampersand
+                || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+              )
+          ? REXEC_COPY_STR
+          : 0;
 
     orig = m = s;
     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
@@ -2203,7 +2214,8 @@ PP(pp_subst)
 #ifdef PERL_OLD_COPY_ON_WRITE
        && !is_cow
 #endif
-       && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
+        && (I32)clen <= RX_MINLENRET(rx)
+        && (once || !(r_flags & REXEC_COPY_STR))
        && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
        && (!doutf8 || SvUTF8(TARG))
        && !(rpm->op_pmflags & PMf_NONDESTRUCT))
@@ -2331,6 +2343,7 @@ PP(pp_subst)
            if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
                m = s;
                s = orig;
+                assert(RX_SUBOFFSET(rx) == 0);
                orig = RX_SUBBEG(rx);
                s = orig + (m - s);
                strend = s + (strend - m);
index 921c0e9..a9e92e1 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) {
-        /* $' */
-       s = rx->subbeg + rx->offs[0].end;
-       i = rx->sublen - rx->offs[0].end;
+    if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
+        && rx->offs[0].end != -1)
+    {
+        /* $', ${^POSTMATCH} */
+       s = rx->subbeg - rx->suboffset + rx->offs[0].end;
+       i = rx->sublen + rx->suboffset - 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;
+        s = rx->subbeg + s1 - rx->suboffset;
     } 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;
@@ -6826,7 +6859,7 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
     }
   getlen:
     if (i > 0 && RXp_MATCH_UTF8(rx)) {
-        const char * const s = rx->subbeg + s1;
+        const char * const s = rx->subbeg - rx->suboffset + s1;
         const U8 *ep;
         STRLEN el;
 
@@ -14429,6 +14462,8 @@ Perl_save_re_context(pTHX)
 
     PL_reg_oldsaved = NULL;
     PL_reg_oldsavedlen = 0;
+    PL_reg_oldsavedoffset = 0;
+    PL_reg_oldsavedcoffset = 0;
     PL_reg_maxiter = 0;
     PL_reg_leftiter = 0;
     PL_reg_poscache = NULL;
index 4c9a456..2dc2314 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -502,10 +502,13 @@ S_regcp_restore(pTHX_ regexp *rex, I32 ix)
 I32
 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
         char *strbeg, I32 minend, SV *screamer, U32 nosave)
-/* strend: pointer to null at end of string */
-/* strbeg: real beginning of string */
-/* minend: end of match must be >=minend after stringarg. */
-/* nosave: For optimizations. */
+/* stringarg: the point in the string at which to begin matching */
+/* strend:    pointer to null at end of string */
+/* strbeg:    real beginning of string */
+/* minend:    end of match must be >= minend bytes after stringarg. */
+/* screamer:  SV being matched: only used for utf8 flag, pos() etc; string
+ *            itself is accessed via the pointers above */
+/* nosave:    For optimizations. */
 {
     PERL_ARGS_ASSERT_PREGEXEC;
 
@@ -2051,13 +2054,17 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
 I32
 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
              char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
-/* strend: pointer to null at end of string */
-/* strbeg: real beginning of string */
-/* minend: end of match must be >=minend after stringarg. */
-/* data: May be used for some additional optimizations. 
-         Currently its only used, with a U32 cast, for transmitting 
-         the ganch offset when doing a /g match. This will change */
-/* nosave: For optimizations. */
+/* stringarg: the point in the string at which to begin matching */
+/* strend:    pointer to null at end of string */
+/* strbeg:    real beginning of string */
+/* minend:    end of match must be >= minend bytes after stringarg. */
+/* sv:        SV being matched: only used for utf8 flag, pos() etc; string
+ *            itself is accessed via the pointers above */
+/* data:      May be used for some additional optimizations.
+              Currently its only used, with a U32 cast, for transmitting
+              the ganch offset when doing a /g match. This will change */
+/* nosave:    For optimizations. */
+
 {
     dVAR;
     struct regexp *const prog = (struct regexp *)SvANY(rx);
@@ -2559,9 +2566,7 @@ got_it:
 
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
-       RX_MATCH_COPY_FREE(rx);
        if (flags & REXEC_COPY_STR) {
-           const I32 i = PL_regeol - startpos + (stringarg - strbeg);
 #ifdef PERL_OLD_COPY_ON_WRITE
            if ((SvIsCOW(sv)
                 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
@@ -2573,17 +2578,105 @@ got_it:
                prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
                prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
                assert (SvPOKp(prog->saved_copy));
+                prog->sublen  = PL_regeol - strbeg;
+                prog->suboffset = 0;
+                prog->subcoffset = 0;
            } else
 #endif
            {
-               RX_MATCH_COPIED_on(rx);
-               s = savepvn(strbeg, i);
-               prog->subbeg = s;
-           }
-           prog->sublen = i;
+                I32 min = 0;
+                I32 max = PL_regeol - strbeg;
+                I32 sublen;
+
+                if (    (flags & REXEC_COPY_SKIP_POST)
+                    && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+                    && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
+                ) { /* don't copy $' part of string */
+                    U32 n = 0;
+                    max = -1;
+                    /* calculate the right-most part of the string covered
+                     * by a capture. Due to look-ahead, this may be to
+                     * the right of $&, so we have to scan all captures */
+                    while (n <= prog->lastparen) {
+                        if (prog->offs[n].end > max)
+                            max = prog->offs[n].end;
+                        n++;
+                    }
+                    if (max == -1)
+                        max = (PL_sawampersand & SAWAMPERSAND_LEFT)
+                                ? prog->offs[0].start
+                                : 0;
+                    assert(max >= 0 && max <= PL_regeol - strbeg);
+                }
+
+                if (    (flags & REXEC_COPY_SKIP_PRE)
+                    && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+                    && !(PL_sawampersand & SAWAMPERSAND_LEFT)
+                ) { /* don't copy $` part of string */
+                    U32 n = 0;
+                    min = max;
+                    /* calculate the left-most part of the string covered
+                     * by a capture. Due to look-behind, this may be to
+                     * the left of $&, so we have to scan all captures */
+                    while (min && n <= prog->lastparen) {
+                        if (   prog->offs[n].start != -1
+                            && prog->offs[n].start < min)
+                        {
+                            min = prog->offs[n].start;
+                        }
+                        n++;
+                    }
+                    if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
+                        && min >  prog->offs[0].end
+                    )
+                        min = prog->offs[0].end;
+
+                }
+
+                assert(min >= 0 && min <= max && min <= PL_regeol - strbeg);
+                sublen = max - min;
+
+                if (RX_MATCH_COPIED(rx)) {
+                    if (sublen > prog->sublen)
+                        prog->subbeg =
+                                (char*)saferealloc(prog->subbeg, sublen+1);
+                }
+                else
+                    prog->subbeg = (char*)safemalloc(sublen+1);
+                Copy(strbeg + min, prog->subbeg, sublen, char);
+                prog->subbeg[sublen] = '\0';
+                prog->suboffset = min;
+                prog->sublen = sublen;
+           }
+            RX_MATCH_COPIED_on(rx);
+            prog->subcoffset = prog->suboffset;
+            if (prog->suboffset && utf8_target) {
+                /* Convert byte offset to chars.
+                 * XXX ideally should only compute this if @-/@+
+                 * has been seen, a la PL_sawampersand ??? */
+
+                /* If there's a direct correspondence between the
+                 * string which we're matching and the original SV,
+                 * then we can use the utf8 len cache associated with
+                 * the SV. In particular, it means that under //g,
+                 * sv_pos_b2u() will use the previously cached
+                 * position to speed up working out the new length of
+                 * subcoffset, rather than counting from the start of
+                 * the string each time. This stops
+                 *   $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
+                 * from going quadratic */
+                if (SvPOKp(sv) && SvPVX(sv) == strbeg)
+                    sv_pos_b2u(sv, &(prog->subcoffset));
+                else
+                    prog->subcoffset = utf8_length((U8*)strbeg,
+                                        (U8*)(strbeg+prog->suboffset));
+            }
        }
        else {
+            RX_MATCH_COPY_FREE(rx);
            prog->subbeg = strbeg;
+           prog->suboffset = 0;
+           prog->subcoffset = 0;
            prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
        }
     }
@@ -2688,6 +2781,8 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
                $` inside (?{}) could fail... */
            PL_reg_oldsaved = prog->subbeg;
            PL_reg_oldsavedlen = prog->sublen;
+           PL_reg_oldsavedoffset = prog->suboffset;
+           PL_reg_oldsavedcoffset = prog->suboffset;
 #ifdef PERL_OLD_COPY_ON_WRITE
            PL_nrs = prog->saved_copy;
 #endif
@@ -2696,6 +2791,8 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
        else
            PL_reg_oldsaved = NULL;
        prog->subbeg = PL_bostr;
+       prog->suboffset = 0;
+       prog->subcoffset = 0;
        prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
     }
 #ifdef DEBUGGING
@@ -4528,6 +4625,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                 RXp_MATCH_COPIED_off(re);
                 re->subbeg = rex->subbeg;
                 re->sublen = rex->sublen;
+                re->suboffset = rex->suboffset;
+                re->subcoffset = rex->subcoffset;
                rei = RXi_GET(re);
                 DEBUG_EXECUTE_r(
                     debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
@@ -7160,6 +7259,8 @@ restore_pos(pTHX_ void *arg)
        if (PL_reg_oldsaved) {
            rex->subbeg = PL_reg_oldsaved;
            rex->sublen = PL_reg_oldsavedlen;
+           rex->suboffset = PL_reg_oldsavedoffset;
+           rex->subcoffset = PL_reg_oldsavedcoffset;
 #ifdef PERL_OLD_COPY_ON_WRITE
            rex->saved_copy = PL_nrs;
 #endif
index db36edd..3e245d0 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -124,6 +124,8 @@ struct reg_code_block {
        char *subbeg;                                                   \
        SV_SAVED_COPY   /* If non-NULL, SV which is COW from original */\
        I32 sublen;     /* Length of string pointed by subbeg */        \
+       I32 suboffset;  /* byte offset of subbeg from logical start of str */ \
+       I32 subcoffset; /* suboffset equiv, but in chars (for @-/@+) */ \
        /* Information about the match that isn't often used */         \
        /* offset from wrapped to the start of precomp */               \
        PERL_BITFIELD32 pre_prefix:4;                                   \
@@ -181,9 +183,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
@@ -474,6 +479,18 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
        assert(SvTYPE(_rx_subbeg) == SVt_REGEXP);                       \
        &SvANY(_rx_subbeg)->subbeg;                                     \
     }))
+#  define RX_SUBOFFSET(prog)                                           \
+    (*({                                                               \
+       const REGEXP *const _rx_suboffset = (prog);                     \
+       assert(SvTYPE(_rx_suboffset) == SVt_REGEXP);                    \
+       &SvANY(_rx_suboffset)->suboffset;                               \
+    }))
+#  define RX_SUBCOFFSET(prog)                                          \
+    (*({                                                               \
+       const REGEXP *const _rx_subcoffset = (prog);                    \
+       assert(SvTYPE(_rx_subcoffset) == SVt_REGEXP);                   \
+       &SvANY(_rx_subcoffset)->subcoffset;                             \
+    }))
 #  define RX_OFFS(prog)                                                        \
     (*({                                                               \
        const REGEXP *const _rx_offs = (prog);                          \
@@ -490,6 +507,8 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 #  define RX_EXTFLAGS(prog)    RXp_EXTFLAGS((struct regexp *)SvANY(prog))
 #  define RX_ENGINE(prog)      (((struct regexp *)SvANY(prog))->engine)
 #  define RX_SUBBEG(prog)      (((struct regexp *)SvANY(prog))->subbeg)
+#  define RX_SUBOFFSET(prog)   (((struct regexp *)SvANY(prog))->suboffset)
+#  define RX_SUBCOFFSET(prog)  (((struct regexp *)SvANY(prog))->subcoffset)
 #  define RX_OFFS(prog)                (((struct regexp *)SvANY(prog))->offs)
 #  define RX_NPARENS(prog)     (((struct regexp *)SvANY(prog))->nparens)
 #endif
@@ -538,6 +557,11 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 #define REXEC_SCREAM   0x04            /* use scream table. */
 #define REXEC_IGNOREPOS        0x08            /* \G matches at start. */
 #define REXEC_NOT_FIRST        0x10            /* This is another iteration of //g. */
+                                    /* under REXEC_COPY_STR, it's ok for the
+                                     * engine (modulo PL_sawamperand etc)
+                                     * to skip copying ... */
+#define REXEC_COPY_SKIP_PRE  0x20   /* ...the $` part of the string, or */
+#define REXEC_COPY_SKIP_POST 0x40   /* ...the $' part of the string */
 
 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
 #  define ReREFCNT_inc(re)                                             \
@@ -760,6 +784,8 @@ typedef struct regmatch_slab {
 #define PL_reg_curpm           PL_reg_state.re_state_reg_curpm
 #define PL_reg_oldsaved                PL_reg_state.re_state_reg_oldsaved
 #define PL_reg_oldsavedlen     PL_reg_state.re_state_reg_oldsavedlen
+#define PL_reg_oldsavedoffset  PL_reg_state.re_state_reg_oldsavedoffset
+#define PL_reg_oldsavedcoffset PL_reg_state.re_state_reg_oldsavedcoffset
 #define PL_reg_maxiter         PL_reg_state.re_state_reg_maxiter
 #define PL_reg_leftiter                PL_reg_state.re_state_reg_leftiter
 #define PL_reg_poscache                PL_reg_state.re_state_reg_poscache
@@ -781,6 +807,8 @@ struct re_save_state {
     PMOP *re_state_reg_curpm;          /* from regexec.c */
     char *re_state_reg_oldsaved;       /* old saved substr during match */
     STRLEN re_state_reg_oldsavedlen;   /* old length of saved substr during match */
+    STRLEN re_state_reg_oldsavedoffset;        /* old offset of saved substr during match */
+    STRLEN re_state_reg_oldsavedcoffset;/* old coffset of saved substr during match */
     STRLEN re_state_reg_poscache_size; /* size of pos cache of WHILEM */
     I32 re_state_reg_oldpos;           /* from regexec.c */
     I32 re_state_reg_maxiter;          /* max wait until caching pos */
index f316fa7..ba4ccf6 100644 (file)
@@ -266,7 +266,7 @@ pod/perlpacktut.pod Verbatim line length including indents exceeds 79 by    6
 pod/perlperf.pod       Verbatim line length including indents exceeds 79 by    154
 pod/perlpodspec.pod    Verbatim line length including indents exceeds 79 by    9
 pod/perlpodstyle.pod   Verbatim line length including indents exceeds 79 by    1
-pod/perlreapi.pod      Verbatim line length including indents exceeds 79 by    17
+pod/perlreapi.pod      Verbatim line length including indents exceeds 79 by    18
 pod/perlrebackslash.pod        Verbatim line length including indents exceeds 79 by    1
 pod/perlref.pod        Verbatim line length including indents exceeds 79 by    1
 pod/perlreguts.pod     Verbatim line length including indents exceeds 79 by    17
index 6692e1c..05cc191 100644 (file)
@@ -1660,7 +1660,6 @@ $x='123';
 print ">$1<\n";
 EOP
 
-        local $::TODO = 'RT #86042';
         fresh_perl_is(<<'EOP', ">abc<\n", {}, 'no mention of $&');
 my $x; 
 ($x='abc')=~/(abc)/g; 
index c5073a5..0433760 100644 (file)
@@ -3,6 +3,9 @@
 # This is a home for regular expression tests that don't fit into
 # the format supported by re/regexp.t.  If you want to add a test
 # that does fit that format, add it to re/re_tests, not here.
+#
+# this file includes test that my burn a lot of CPU or otherwise be heavy
+# on resources. Set env var $PERL_SKIP_PSYCHO_TEST to skip this file
 
 use strict;
 use warnings;
@@ -21,7 +24,8 @@ BEGIN {
 }
 
 
-plan tests => 11;  # Update this when adding/deleting tests.
+skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};
+plan tests => 15;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -29,16 +33,17 @@ run_tests() unless caller;
 # Tests start here.
 #
 sub run_tests {
+    print "# Set PERL_SKIP_PSYCHO_TEST to skip these tests\n";
 
-  SKIP:
     {
-        print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
-        my @normal = qw [the are some normal words];
 
-        skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST};
+       # stress test tries
+
+        my @normal = qw [the are some normal words];
 
         local $" = "|";
 
+       note "setting up trie psycho vars ...";
         my @psycho = (@normal, map chr $_, 255 .. 20000);
         my $psycho1 = "@psycho";
         for (my $i = @psycho; -- $i;) {
@@ -48,13 +53,12 @@ sub run_tests {
         my $psycho2 = "@psycho";
 
         foreach my $word (@normal) {
-            ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho';
-            ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho';
+            ok $word =~ /($psycho1)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
+            ok $word =~ /($psycho2)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
         }
     }
 
 
-  SKIP:
     {
         # stress test CURLYX/WHILEM.
         #
@@ -63,8 +67,6 @@ sub run_tests {
         # CURLYX and WHILEM blocks, except those related to LONGJMP, the
         # super-linear cache and warnings. It executes about 0.5M regexes
 
-        skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST};
-        print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
         my $r = qr/^
                     (?:
                         ( (?:a|z+)+ )
@@ -158,6 +160,49 @@ sub run_tests {
         }
         ok($ok, $msg);
     }
+
+
+    {
+       # these bits of test code used to run quadratically. If we break
+       # anything, they'll start to take minutes to run, rather than
+       # seconds. We don't actually measure times or set alarms, since
+       # that tends to be very fragile and prone to false positives.
+       # Instead, just hope that if someone is messing with
+       # performance-related code, they'll re-run the test suite and
+       # notice it suddenly takes a lot longer.
+
+       my $x;
+
+       $x = 'x' x 1_000_000;
+       1 while $x =~ /(.)/g;
+       pass "ascii =~ /(.)/";
+
+       {
+           local ${^UTF8CACHE} = 1; # defeat debugging
+           $x = "\x{100}" x 1_000_000;
+           1 while $x =~ /(.)/g;
+           pass "utf8 =~ /(.)/";
+       }
+
+       # run these in separate processes, since they set $&
+
+        fresh_perl_is(<<'EOF', "ok\n", {}, 'ascii =~ /(.)/, mention $&');
+$&;
+$x = 'x' x 1_000_000;
+1 while $x =~ /(.)/g;
+print "ok\n";
+EOF
+
+        fresh_perl_is(<<'EOF', "ok\n", {}, 'utf8 =~ /(.)/, mention $&');
+$&;
+local ${^UTF8CACHE} = 1; # defeat debugging
+$x = "\x{100}" x 1_000_000;
+1 while $x =~ /(.)/g;
+print "ok\n";
+EOF
+
+
+    }
 } # End of sub run_tests
 
 1;
index f44bdc1..1aebbe6 100644 (file)
@@ -163,6 +163,7 @@ ab|cd       abcd    y       $&      ab
 ()ef   def     y       $&-$1   ef-
 ()ef   def     y       $-[0]   1
 ()ef   def     y       $+[0]   3
+()\x{100}\x{1000}      d\x{100}\x{1000}        y       $+[0]   3
 ()ef   def     y       $-[1]   1
 ()ef   def     y       $+[1]   1
 *a     -       c       -       Quantifier follows nothing
@@ -1702,5 +1703,10 @@ ab[c\\\](??{"x"})]{3}d   ab\\](d y       -       -
 \W     \x{200D}        n       -       -
 
 /^(?d:\xdf|_)*_/i      \x{17f}\x{17f}_ y       $&      \x{17f}\x{17f}_
+#
+# check that @-, @+ count chars, not bytes; especially if beginning of
+# string is not copied
+
+(\x{100})      \x{2000}\x{2000}\x{2000}\x{100} y       $-[0]:$-[1]:$+[0]:$+[1] 3:3:4:4
 
 # vim: softtabstop=0 noexpandtab
index 301aeef..3190e03 100644 (file)
@@ -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");