Add Artistic as perlartistic and GPL (the Copying) as perlgpl;

[p5sagit/p5-mst-13.2.git] / regexec.c

diff --git a/regexec.c b/regexec.c
index 40f33d4..a3c7a7d 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -67,7 +67,8 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1991-2002, Larry Wall
+ ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ ****    2000, 2001, 2002, 2003, by Larry Wall and others
  ****
  ****    You may distribute under the terms of either the GNU General Public
  ****    License or the Artistic License, as specified in the README file.
@@ -544,7 +545,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
            goto fail_finish;
        /* we may be pointing at the wrong string */
        if (s && RX_MATCH_COPIED(prog))
-           s = prog->subbeg + (s - SvPVX(sv));
+           s = strbeg + (s - SvPVX(sv));
        if (data)
            *data->scream_olds = s;
     }
@@ -852,10 +853,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        char *startpos = strbeg;
 
        t = s;
-       if (prog->reganch & ROPT_UTF8) {        
-           PL_regdata = prog->data;
-           PL_bostr = startpos;
-       }
        cache_re(prog);
        s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
        if (!s) {
@@ -1866,7 +1863,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                                  PL_multiline ? FBMrf_MULTILINE : 0))) ) {
            /* we may be pointing at the wrong string */
            if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
-               s = prog->subbeg + (s - SvPVX(sv));
+               s = strbeg + (s - SvPVX(sv));
            DEBUG_r( did_match = 1 );
            if (HOPc(s, -back_max) > last1) {
                last1 = HOPc(s, -back_min);
@@ -1955,7 +1952,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                    last = scream_olds; /* Only one occurrence. */
                /* we may be pointing at the wrong string */
                else if (RX_MATCH_COPIED(prog))
-                   s = prog->subbeg + (s - SvPVX(sv));
+                   s = strbeg + (s - SvPVX(sv));
            }
            else {
                STRLEN len;
@@ -2023,17 +2020,28 @@ got_it:
 
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
-       if (RX_MATCH_COPIED(prog)) {
-           Safefree(prog->subbeg);
-           RX_MATCH_COPIED_off(prog);
-       }
+       RX_MATCH_COPY_FREE(prog);
        if (flags & REXEC_COPY_STR) {
            I32 i = PL_regeol - startpos + (stringarg - strbeg);
-
-           s = savepvn(strbeg, i);
-           prog->subbeg = s;
+#ifdef PERL_COPY_ON_WRITE
+           if ((SvIsCOW(sv)
+                || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+               if (DEBUG_C_TEST) {
+                   PerlIO_printf(Perl_debug_log,
+                                 "Copy on write: regexp capture, type %d\n",
+                                 (int) SvTYPE(sv));
+               }
+               prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
+               prog->subbeg = SvPVX(prog->saved_copy);
+               assert (SvPOKp(prog->saved_copy));
+           } else
+#endif
+           {
+               RX_MATCH_COPIED_on(prog);
+               s = savepvn(strbeg, i);
+               prog->subbeg = s;
+           }
            prog->sublen = i;
-           RX_MATCH_COPIED_on(prog);
        }
        else {
            prog->subbeg = strbeg;
@@ -2123,6 +2131,9 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
                $` inside (?{}) could fail... */
            PL_reg_oldsaved = prog->subbeg;
            PL_reg_oldsavedlen = prog->sublen;
+#ifdef PERL_COPY_ON_WRITE
+           PL_nrs = prog->saved_copy;
+#endif
            RX_MATCH_COPIED_off(prog);
        }
        else
@@ -2853,13 +2864,17 @@ S_regmatch(pTHX_ regnode *prog)
                    re_cc_state state;
                    CHECKPOINT cp, lastcp;
                     int toggleutf;
+                   register SV *sv;
 
-                   if(SvROK(ret) || SvRMAGICAL(ret)) {
-                       SV *sv = SvROK(ret) ? SvRV(ret) : ret;
-
-                       if(SvMAGICAL(sv))
-                           mg = mg_find(sv, PERL_MAGIC_qr);
+                   if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
+                       mg = mg_find(sv, PERL_MAGIC_qr);
+                   else if (SvSMAGICAL(ret)) {
+                       if (SvGMAGICAL(ret))
+                           sv_unmagic(ret, PERL_MAGIC_qr);
+                       else
+                           mg = mg_find(ret, PERL_MAGIC_qr);
                    }
+
                    if (mg) {
                        re = (regexp *)mg->mg_obj;
                        (void)ReREFCNT_inc(re);
@@ -2876,7 +2891,8 @@ S_regmatch(pTHX_ regnode *prog)
                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
                        re = CALLREGCOMP(aTHX_ t, t + len, &pm);
                        if (!(SvFLAGS(ret)
-                             & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
+                             & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
+                               | SVs_GMG)))
                            sv_magic(ret,(SV*)ReREFCNT_inc(re),
                                        PERL_MAGIC_qr,0,0);
                        PL_regprecomp = oprecomp;
@@ -4555,6 +4571,9 @@ restore_pos(pTHX_ void *arg)
        if (PL_reg_oldsaved) {
            PL_reg_re->subbeg = PL_reg_oldsaved;
            PL_reg_re->sublen = PL_reg_oldsavedlen;
+#ifdef PERL_COPY_ON_WRITE
+           PL_reg_re->saved_copy = PL_nrs;
+#endif
            RX_MATCH_COPIED_on(PL_reg_re);
        }
        PL_reg_magic->mg_len = PL_reg_oldpos;