Allow regexp-to-pvlv assignment
authorFather Chrysostomos <sprout@cpan.org>
Tue, 30 Oct 2012 16:44:26 +0000 (09:44 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 30 Oct 2012 19:36:45 +0000 (12:36 -0700)
Since the xpvlv and regexp structs conflict, we have to find somewhere
else to put the regexp struct.

I was going to sneak it in SvPVX, allocating a buffer large
enough to fit the regexp struct followed by the string, and have
SvPVX - sizeof(regexp) point to the struct.  But that would make all
regexp flag-checking macros fatter, and those are used in hot code.

So I came up with another method.  Regexp stringification is not
speed-critical.  So we can move the regexp stringification out of
re->sv_u and put it in the regexp struct.  Then the regexp struct
itself can be pointed to by re->sv_u.  So SVt_REGEXPs will have
re->sv_any and re->sv_u pointing to the same spot.  PVLVs can then
have sv->sv_any point to the xpvlv body as usual, but have sv->sv_u
point to a regexp struct.  All regexp member access can go through
sv_u instead of sv_any, which will be no slower than before.

Regular expressions will no longer be SvPOK, so we give sv_2pv spec-
ial logic for regexps.  We don’t need to make the regexp struct
larger, as SvLEN is currently always 0 iff mother_re is set.  So we
can replace the SvLEN field with the pv.

SvFAKE is never used without SvPOK or SvSCREAM also set.  So we can
use that to identify regexps.

16 files changed:
dump.c
ext/B/B.xs
ext/B/B/Concise.pm
ext/Devel-Peek/t/Peek.t
inline.h
op.c
perl.h
pp_ctl.c
pp_hot.c
regcomp.c
regcomp.h
regexec.c
regexp.h
sv.c
sv.h
t/op/qr.t

index 72f7c4e..4eadad0 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1612,7 +1612,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     }
 
     if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
-       if (SvPVX_const(sv)) {
+       const bool re = isREGEXP(sv);
+       const char * const ptr =
+           re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
+       if (ptr) {
            STRLEN delta;
            if (SvOOK(sv)) {
                SvOOK_offset(sv, delta);
@@ -1621,18 +1624,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            } else {
                delta = 0;
            }
-           Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
+           Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
            if (SvOOK(sv)) {
                PerlIO_printf(file, "( %s . ) ",
-                             pv_display(d, SvPVX_const(sv) - delta, delta, 0,
+                             pv_display(d, ptr - delta, delta, 0,
                                         pvlim));
            }
-           PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
+           PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
+                                                re ? 0 : SvLEN(sv),
+                                                pvlim));
            if (SvUTF8(sv)) /* the 6?  \x{....} */
                PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
            PerlIO_printf(file, "\n");
            Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
-           Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
+           if (!re)
+               Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
+                                      (IV)SvLEN(sv));
        }
        else
            Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
@@ -1958,6 +1965,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
                    dumpops, pvlim);
        }
+       if (isREGEXP(sv)) goto dumpregexp;
        if (!isGV_with_GP(sv))
            break;
        Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
@@ -2026,8 +2034,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
        break;
     case SVt_REGEXP:
+      dumpregexp:
        {
-           struct regexp * const r = (struct regexp *)SvANY(sv);
+           struct regexp * const r = ReANY((REGEXP*)sv);
            flags = RX_EXTFLAGS((REGEXP*)sv);
            sv_setpv(d,"");
            append_flags(d, flags, regexp_flags_names);
index eb0a37b..a4386b6 100644 (file)
@@ -1510,20 +1510,37 @@ PV(sv)
               5.15 and later store the BM table via MAGIC, so the compiler
               should handle this just fine without changes if PVBM now
               always returns the SvPVX() buffer.  */
+#ifdef isREGEXP
+           p = isREGEXP(sv)
+                ? RX_WRAPPED_const((REGEXP*)sv)
+                : SvPVX_const(sv);
+#else
            p = SvPVX_const(sv);
+#endif
 #ifdef PERL_FBM_TABLE_OFFSET
            len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
 #else
            len = SvCUR(sv);
 #endif
        } else if (ix) {
+#ifdef isREGEXP
+           p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
+#else
            p = SvPVX(sv);
+#endif
            len = strlen(p);
        } else if (SvPOK(sv)) {
            len = SvCUR(sv);
            p = SvPVX_const(sv);
            utf8 = SvUTF8(sv);
         }
+#ifdef isREGEXP
+       else if (isREGEXP(sv)) {
+           len = SvCUR(sv);
+           p = RX_WRAPPED_const((REGEXP*)sv);
+           utf8 = SvUTF8(sv);
+       }
+#endif
         else {
             /* XXX for backward compatibility, but should fail */
             /* croak( "argument is not SvPOK" ); */
index 130c84c..796841a 100644 (file)
@@ -732,13 +732,14 @@ sub concise_sv {
        }
        if (class($sv) eq "SPECIAL") {
            $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
-       } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+       } elsif ($preferpv
+             && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
            $hr->{svval} .= cstring($sv->PV);
        } elsif ($sv->FLAGS & SVf_NOK) {
            $hr->{svval} .= $sv->NV;
        } elsif ($sv->FLAGS & SVf_IOK) {
            $hr->{svval} .= $sv->int_value;
-       } elsif ($sv->FLAGS & SVf_POK) {
+       } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
            $hr->{svval} .= cstring($sv->PV);
        } elsif (class($sv) eq "HV") {
            $hr->{svval} .= 'HASH';
index cdb3276..11217b0 100644 (file)
@@ -333,10 +333,11 @@ do_test('reference to regexp',
   RV = $ADDR
   SV = REGEXP\\($ADDR\\) at $ADDR
     REFCNT = 1
-    FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
+    FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)         # $] < 5.017006
+    FLAGS = \\(OBJECT,FAKE\\)                  # $] >= 5.017006
     PV = $ADDR "\\(\\?\\^:tic\\)"
     CUR = 8
-    LEN = 0
+    LEN = 0                                    # $] < 5.017006
     STASH = $ADDR\\t"Regexp"'
 . ($] < 5.013 ? '' :
 '
index 69807f1..0d53860 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -21,6 +21,15 @@ S_CvDEPTHp(const CV * const sv)
     return &((XPVCV*)SvANY(sv))->xcv_depth;
 }
 
+/* ----------------------------- regexp.h ----------------------------- */
+
+PERL_STATIC_INLINE struct regexp *
+S_ReANY(const REGEXP * const re)
+{
+    assert(isREGEXP(re));
+    return re->sv_u.svu_rx;
+}
+
 /* ------------------------------- sv.h ------------------------------- */
 
 PERL_STATIC_INLINE SV *
diff --git a/op.c b/op.c
index df5c050..b255b38 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4644,7 +4644,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
                /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
                SvREFCNT_inc_simple_void(PL_compcv);
                cv = newATTRSUB(floor, 0, NULL, NULL, qr);
-               ((struct regexp *)SvANY(re))->qr_anoncv = cv;
+               ReANY(re)->qr_anoncv = cv;
 
                /* attach the anon CV to the pad so that
                 * pad_fixup_inner_anons() can find it */
diff --git a/perl.h b/perl.h
index dfa0a4a..ae84dba 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5148,7 +5148,7 @@ PL_valid_types_IVX[]    = { 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
 EXTCONST bool
 PL_valid_types_NVX[]    = { 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 };
 EXTCONST bool
-PL_valid_types_PVX[]    = { 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1 };
+PL_valid_types_PVX[]    = { 0, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1 };
 EXTCONST bool
 PL_valid_types_RV[]     = { 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1 };
 EXTCONST bool
index bc9b647..869907d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -116,7 +116,7 @@ PP(pp_regcomp)
                pm->op_pmflags |
                    (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
     if (pm->op_pmflags & PMf_HAS_CV)
-       ((struct regexp *)SvANY(new_re))->qr_anoncv
+       ReANY(new_re)->qr_anoncv
                        = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
 
     if (is_bare_re) {
index 13123bb..868240b 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1205,7 +1205,7 @@ PP(pp_qr)
     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
     SvROK_on(rv);
 
-    cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
+    cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
     if ((cv = *cvp) && CvCLONE(*cvp)) {
        *cvp = cv_clone(cv);
        SvREFCNT_dec(cv);
@@ -1258,7 +1258,7 @@ PP(pp_match)
     PUTBACK;                           /* EVAL blocks need stack_sp. */
     /* Skip get-magic if this is a qr// clone, because regcomp has
        already done it. */
-    s = ((struct regexp *)SvANY(rx))->mother_re
+    s = ReANY(rx)->mother_re
         ? SvPV_nomg_const(TARG, len)
         : SvPV_const(TARG, len);
     if (!s)
@@ -1290,7 +1290,7 @@ PP(pp_match)
 
     /* empty pattern special-cased to use last successful pattern if
        possible, except for qr// */
-    if (!((struct regexp *)SvANY(rx))->mother_re && !RX_PRELEN(rx)
+    if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
      && PL_curpm) {
        pm = PL_curpm;
        rx = PM_GETRE(pm);
@@ -2134,7 +2134,7 @@ PP(pp_subst)
                                   second time with non-zero. */
 
     if (!RX_PRELEN(rx) && PL_curpm
-     && !((struct regexp *)SvANY(rx))->mother_re) {
+     && !ReANY(rx)->mother_re) {
        pm = PL_curpm;
        rx = PM_GETRE(pm);
     }
index d524a99..7114355 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -5123,7 +5123,7 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
 
     /* merge the main (r1) and run-time (r2) code blocks into one */
     {
-       RXi_GET_DECL(((struct regexp*)SvANY(qr)), r2);
+       RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
        struct reg_code_block *new_block, *dst;
        RExC_state_t * const r1 = pRExC_state; /* convenient alias */
        int i1 = 0, i2 = 0;
@@ -5500,7 +5500,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                    && RX_ENGINE((REGEXP*)rx)->op_comp)
                {
 
-                   RXi_GET_DECL(((struct regexp*)SvANY(rx)), ri);
+                   RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
                    if (ri->num_code_blocks) {
                        int i;
                        /* the presence of an embedded qr// with code means
@@ -5515,7 +5515,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                        for (i=0; i < ri->num_code_blocks; i++) {
                            struct reg_code_block *src, *dst;
                            STRLEN offset =  orig_patlen
-                               + ((struct regexp *)SvANY(rx))->pre_prefix;
+                               + ReANY((REGEXP *)rx)->pre_prefix;
                            assert(n < pRExC_state->num_code_blocks);
                            src = &ri->code_blocks[i];
                            dst = &pRExC_state->code_blocks[n];
@@ -5845,7 +5845,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
        of zeroing when in debug mode, thus anything assigned has to 
        happen after that */
     rx = (REGEXP*) newSV_type(SVt_REGEXP);
-    r = (struct regexp*)SvANY(rx);
+    r = ReANY(rx);
     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
         char, regexp_internal);
     if ( r == NULL || ri == NULL )
@@ -5898,8 +5898,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
             + (sizeof(STD_PAT_MODS) - 1)
             + (sizeof("(?:)") - 1);
 
-        p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
-       SvPOK_on(rx);
+        Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
+       r->xpv_len_u.xpvlenu_pv = p;
        if (RExC_utf8)
            SvFLAGS(rx) |= SVf_UTF8;
         *p++='('; *p++='?';
@@ -5934,7 +5934,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
             *p++ = '\n';
         *p++ = ')';
         *p = 0;
-       SvCUR_set(rx, p - SvPVX_const(rx));
+       SvCUR_set(rx, p - RX_WRAPPED(rx));
     }
 
     r->intflags = 0;
@@ -6489,7 +6489,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
 {
     AV *retarray = NULL;
     SV *ret;
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
 
@@ -6529,7 +6529,7 @@ bool
 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
                            const U32 flags)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
 
@@ -6553,7 +6553,7 @@ Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
 SV*
 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
 
@@ -6569,7 +6569,7 @@ Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
 SV*
 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
     GET_RE_DEBUG_FLAGS_DECL;
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
@@ -6605,7 +6605,7 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
     SV *ret;
     AV *av;
     I32 length;
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
 
@@ -6629,7 +6629,7 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
 SV*
 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
     AV *av = newAV();
 
     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
@@ -6665,7 +6665,7 @@ void
 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
                             SV * const sv)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
     char *s = NULL;
     I32 i = 0;
     I32 s1, t1;
@@ -6775,7 +6775,7 @@ I32
 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
                               const I32 paren)
 {
-    struct regexp *const rx = (struct regexp *)SvANY(r);
+    struct regexp *const rx = ReANY(r);
     I32 i;
     I32 s1, t1;
 
@@ -14077,7 +14077,7 @@ SV *
 Perl_re_intuit_string(pTHX_ REGEXP * const r)
 {                              /* Assume that RE_INTUIT is set */
     dVAR;
-    struct regexp *const prog = (struct regexp *)SvANY(r);
+    struct regexp *const prog = ReANY(r);
     GET_RE_DEBUG_FLAGS_DECL;
 
     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
@@ -14125,7 +14125,7 @@ void
 Perl_pregfree2(pTHX_ REGEXP *rx)
 {
     dVAR;
-    struct regexp *const r = (struct regexp *)SvANY(rx);
+    struct regexp *const r = ReANY(rx);
     GET_RE_DEBUG_FLAGS_DECL;
 
     PERL_ARGS_ASSERT_PREGFREE2;
@@ -14135,6 +14135,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
     } else {
         CALLREGFREE_PVT(rx); /* free the private data */
         SvREFCNT_dec(RXp_PAREN_NAMES(r));
+       Safefree(r->xpv_len_u.xpvlenu_pv);
     }        
     if (r->substrs) {
         SvREFCNT_dec(r->anchored_substr);
@@ -14149,6 +14150,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
 #endif
     Safefree(r->offs);
     SvREFCNT_dec(r->qr_anoncv);
+    rx->sv_u.svu_rx = 0;
 }
 
 /*  reg_temp_copy()
@@ -14172,28 +14174,42 @@ REGEXP *
 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
 {
     struct regexp *ret;
-    struct regexp *const r = (struct regexp *)SvANY(rx);
+    struct regexp *const r = ReANY(rx);
+    const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
 
     PERL_ARGS_ASSERT_REG_TEMP_COPY;
 
     if (!ret_x)
        ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
+    else {
+       SvOK_off((SV *)ret_x);
+       if (islv) {
+           /* For PVLVs, SvANY points to the xpvlv body while sv_u points
+              to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
+              made both spots point to the same regexp body.) */
+           REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
+           assert(!SvPVX(ret_x));
+           ret_x->sv_u.svu_rx = temp->sv_any;
+           temp->sv_any = NULL;
+           SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
+           SvREFCNT_dec(temp);
+           /* SvCUR still resides in the xpvlv struct, so the regexp copy-
+              ing below will not set it. */
+           SvCUR_set(ret_x, SvCUR(rx));
+       }
+    }
     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
        sv_force_normal(sv) is called.  */
     SvFAKE_on(ret_x);
-    ret = (struct regexp *)SvANY(ret_x);
+    ret = ReANY(ret_x);
     
-    (void)ReREFCNT_inc(rx);
-    /* We can take advantage of the existing "copied buffer" mechanism in SVs
-       by pointing directly at the buffer, but flagging that the allocated
-       space in the copy is zero. As we've just done a struct copy, it's now
-       a case of zero-ing that, rather than copying the current length.  */
-    if (SvPOKp(ret_x)) SvPV_free(ret_x);
-    SvPV_set(ret_x, RX_WRAPPED(rx));
-    SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
+    SvFLAGS(ret_x) |= SvUTF8(rx);
+    /* We share the same string buffer as the original regexp, on which we
+       hold a reference count, incremented when mother_re is set below.
+       The string pointer is copied here, being part of the regexp struct.
+     */
     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
           sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
-    SvLEN_set(ret_x, 0);
     if (r->offs) {
         const I32 npar = r->nparens+1;
         Newx(ret->offs, npar, regexp_paren_pair);
@@ -14215,7 +14231,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
 #ifdef PERL_OLD_COPY_ON_WRITE
     ret->saved_copy = NULL;
 #endif
-    ret->mother_re = rx;
+    ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
     SvREFCNT_inc_void(ret->qr_anoncv);
     
     return ret_x;
@@ -14238,7 +14254,7 @@ void
 Perl_regfree_internal(pTHX_ REGEXP * const rx)
 {
     dVAR;
-    struct regexp *const r = (struct regexp *)SvANY(rx);
+    struct regexp *const r = ReANY(rx);
     RXi_GET_DECL(r,ri);
     GET_RE_DEBUG_FLAGS_DECL;
 
@@ -14359,8 +14375,8 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
 {
     dVAR;
     I32 npar;
-    const struct regexp *r = (const struct regexp *)SvANY(sstr);
-    struct regexp *ret = (struct regexp *)SvANY(dstr);
+    const struct regexp *r = ReANY(sstr);
+    struct regexp *ret = ReANY(dstr);
     
     PERL_ARGS_ASSERT_RE_DUP_GUTS;
 
@@ -14424,21 +14440,14 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
     ret->saved_copy = NULL;
 #endif
 
-    if (ret->mother_re) {
-       if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
-           /* Our storage points directly to our mother regexp, but that's
+    /* Whether mother_re be set or no, we need to copy the string.  We
+       cannot refrain from copying it when the storage points directly to
+       our mother regexp, because that's
               1: a buffer in a different thread
               2: something we no longer hold a reference on
               so we need to copy it locally.  */
-           /* Note we need to use SvCUR(), rather than
-              SvLEN(), on our mother_re, because it, in
-              turn, may well be pointing to its own mother_re.  */
-           SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
-                                  SvCUR(ret->mother_re)+1));
-           SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
-       }
-       ret->mother_re      = NULL;
-    }
+    RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
+    ret->mother_re   = NULL;
     ret->gofs = 0;
 }
 #endif /* PERL_IN_XSUB_RE */
@@ -14461,7 +14470,7 @@ void *
 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
 {
     dVAR;
-    struct regexp *const r = (struct regexp *)SvANY(rx);
+    struct regexp *const r = ReANY(rx);
     regexp_internal *reti;
     int len;
     RXi_GET_DECL(r,ri);
index dde4eef..e9a64fe 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -586,10 +586,10 @@ struct reg_data {
 #define check_offset_max substrs->data[2].max_offset
 #define check_end_shift substrs->data[2].end_shift
 
-#define RX_ANCHORED_SUBSTR(rx) (((struct regexp *)SvANY(rx))->anchored_substr)
-#define RX_ANCHORED_UTF8(rx)   (((struct regexp *)SvANY(rx))->anchored_utf8)
-#define RX_FLOAT_SUBSTR(rx)    (((struct regexp *)SvANY(rx))->float_substr)
-#define RX_FLOAT_UTF8(rx)      (((struct regexp *)SvANY(rx))->float_utf8)
+#define RX_ANCHORED_SUBSTR(rx) (ReANY(rx)->anchored_substr)
+#define RX_ANCHORED_UTF8(rx)   (ReANY(rx)->anchored_utf8)
+#define RX_FLOAT_SUBSTR(rx)    (ReANY(rx)->float_substr)
+#define RX_FLOAT_UTF8(rx)      (ReANY(rx)->float_utf8)
 
 /* trie related stuff */
 
index a48643a..ecf8f87 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -579,7 +579,7 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
                     char *strend, const U32 flags, re_scream_pos_data *data)
 {
     dVAR;
-    struct regexp *const prog = (struct regexp *)SvANY(rx);
+    struct regexp *const prog = ReANY(rx);
     I32 start_shift = 0;
     /* Should be nonnegative! */
     I32 end_shift   = 0;
@@ -2095,7 +2095,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *stre
 
 {
     dVAR;
-    struct regexp *const prog = (struct regexp *)SvANY(rx);
+    struct regexp *const prog = ReANY(rx);
     /*register*/ char *s;
     regnode *c;
     /*register*/ char *startpos = stringarg;
@@ -2796,7 +2796,7 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
     dVAR;
     CHECKPOINT lastcp;
     REGEXP *const rx = reginfo->prog;
-    regexp *const prog = (struct regexp *)SvANY(rx);
+    regexp *const prog = ReANY(rx);
     I32 result;
     RXi_GET_DECL(prog,progi);
     GET_RE_DEBUG_FLAGS_DECL;
@@ -3538,7 +3538,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
     const bool utf8_target = PL_reg_match_utf8;
     const U32 uniflags = UTF8_ALLOW_DEFAULT;
     REGEXP *rex_sv = reginfo->prog;
-    regexp *rex = (struct regexp *)SvANY(rex_sv);
+    regexp *rex = ReANY(rex_sv);
     RXi_GET_DECL(rex,rexi);
     I32        oldsave;
     /* the current state. This is a cached copy of PL_regmatch_state */
@@ -4768,7 +4768,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                n = ARG(scan);
 
                if (rexi->data->what[n] == 'r') { /* code from an external qr */
-                   newcv = ((struct regexp *)SvANY(
+                   newcv = (ReANY(
                                                (REGEXP*)(rexi->data->data[n])
                                            ))->qr_anoncv
                                        ;
@@ -4962,7 +4962,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                         * compiled */
                        S_regcp_restore(aTHX_ rex, runops_cp);
                    }
-                   re = (struct regexp *)SvANY(re_sv);
+                   re = ReANY(re_sv);
                }
                 RXp_MATCH_COPIED_off(re);
                 re->subbeg = rex->subbeg;
@@ -5017,7 +5017,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
            PL_reg_flags ^= ST.toggle_reg_flags; 
            rex_sv = ST.prev_rex;
            SET_reg_curpm(rex_sv);
-           rex = (struct regexp *)SvANY(rex_sv);
+           rex = ReANY(rex_sv);
            rexi = RXi_GET(rex);
            regcpblow(ST.cp);
            cur_eval = ST.prev_eval;
@@ -5035,7 +5035,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
            PL_reg_flags ^= ST.toggle_reg_flags; 
            rex_sv = ST.prev_rex;
            SET_reg_curpm(rex_sv);
-           rex = (struct regexp *)SvANY(rex_sv);
+           rex = ReANY(rex_sv);
            rexi = RXi_GET(rex); 
 
            REGCP_UNWIND(ST.lastcp);
@@ -6072,7 +6072,7 @@ NULL
                st->u.eval.cp = regcppush(rex, 0); /* Save *all* the positions. */
                rex_sv = cur_eval->u.eval.prev_rex;
                SET_reg_curpm(rex_sv);
-               rex = (struct regexp *)SvANY(rex_sv);
+               rex = ReANY(rex_sv);
                rexi = RXi_GET(rex);
                cur_curlyx = cur_eval->u.eval.prev_curlyx;
 
index e1d5906..a462001 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -457,76 +457,31 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 #define RXp_EXTFLAGS(rx)       ((rx)->extflags)
 
 /* For source compatibility. We used to store these explicitly.  */
-#define RX_PRECOMP(prog)       (RX_WRAPPED(prog) + ((struct regexp *)SvANY(prog))->pre_prefix)
-#define RX_PRECOMP_const(prog) (RX_WRAPPED_const(prog) + ((struct regexp *)SvANY(prog))->pre_prefix)
+#define RX_PRECOMP(prog)       (RX_WRAPPED(prog) + ReANY(prog)->pre_prefix)
+#define RX_PRECOMP_const(prog) (RX_WRAPPED_const(prog) + ReANY(prog)->pre_prefix)
 /* FIXME? Are we hardcoding too much here and constraining plugin extension
    writers? Specifically, the value 1 assumes that the wrapped version always
    has exactly one character at the end, a ')'. Will that always be true?  */
-#define RX_PRELEN(prog)                (RX_WRAPLEN(prog) - ((struct regexp *)SvANY(prog))->pre_prefix - 1)
-#define RX_WRAPPED(prog)       SvPVX(prog)
-#define RX_WRAPPED_const(prog) SvPVX_const(prog)
+#define RX_PRELEN(prog)                (RX_WRAPLEN(prog) - ReANY(prog)->pre_prefix - 1)
+#define RX_WRAPPED(prog)       ReANY(prog)->xpv_len_u.xpvlenu_pv
+#define RX_WRAPPED_const(prog) ((const char *)RX_WRAPPED(prog))
 #define RX_WRAPLEN(prog)       SvCUR(prog)
-#define RX_CHECK_SUBSTR(prog)  (((struct regexp *)SvANY(prog))->check_substr)
+#define RX_CHECK_SUBSTR(prog)  (ReANY(prog)->check_substr)
 #define RX_REFCNT(prog)                SvREFCNT(prog)
-#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-#  define RX_EXTFLAGS(prog)                                            \
-    (*({                                                               \
-       const REGEXP *const _rx_extflags = (prog);                      \
-       assert(SvTYPE(_rx_extflags) == SVt_REGEXP);                     \
-       &RXp_EXTFLAGS(SvANY(_rx_extflags));                             \
-    }))
-#  define RX_ENGINE(prog)                                              \
-    (*({                                                               \
-       const REGEXP *const _rx_engine = (prog);                        \
-       assert(SvTYPE(_rx_engine) == SVt_REGEXP);                       \
-       &SvANY(_rx_engine)->engine;                                     \
-    }))
-#  define RX_SUBBEG(prog)                                              \
-    (*({                                                               \
-       const REGEXP *const _rx_subbeg = (prog);                        \
-       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);                          \
-       assert(SvTYPE(_rx_offs) == SVt_REGEXP);                         \
-       &SvANY(_rx_offs)->offs;                                         \
-    }))
-#  define RX_NPARENS(prog)                                             \
-    (*({                                                               \
-       const REGEXP *const _rx_nparens = (prog);                       \
-       assert(SvTYPE(_rx_nparens) == SVt_REGEXP);                      \
-       &SvANY(_rx_nparens)->nparens;                                   \
-    }))
-#else
-#  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
-#define RX_SUBLEN(prog)                (((struct regexp *)SvANY(prog))->sublen)
-#define RX_MINLEN(prog)                (((struct regexp *)SvANY(prog))->minlen)
-#define RX_MINLENRET(prog)     (((struct regexp *)SvANY(prog))->minlenret)
-#define RX_GOFS(prog)          (((struct regexp *)SvANY(prog))->gofs)
-#define RX_LASTPAREN(prog)     (((struct regexp *)SvANY(prog))->lastparen)
-#define RX_LASTCLOSEPAREN(prog)        (((struct regexp *)SvANY(prog))->lastcloseparen)
-#define RX_SAVED_COPY(prog)    (((struct regexp *)SvANY(prog))->saved_copy)
+#define RX_EXTFLAGS(prog)      RXp_EXTFLAGS(ReANY(prog))
+#define RX_ENGINE(prog)                (ReANY(prog)->engine)
+#define RX_SUBBEG(prog)                (ReANY(prog)->subbeg)
+#define RX_SUBOFFSET(prog)     (ReANY(prog)->suboffset)
+#define RX_SUBCOFFSET(prog)    (ReANY(prog)->subcoffset)
+#define RX_OFFS(prog)          (ReANY(prog)->offs)
+#define RX_NPARENS(prog)       (ReANY(prog)->nparens)
+#define RX_SUBLEN(prog)                (ReANY(prog)->sublen)
+#define RX_MINLEN(prog)                (ReANY(prog)->minlen)
+#define RX_MINLENRET(prog)     (ReANY(prog)->minlenret)
+#define RX_GOFS(prog)          (ReANY(prog)->gofs)
+#define RX_LASTPAREN(prog)     (ReANY(prog)->lastparen)
+#define RX_LASTCLOSEPAREN(prog)        (ReANY(prog)->lastcloseparen)
+#define RX_SAVED_COPY(prog)    (ReANY(prog)->saved_copy)
 
 #endif /* PLUGGABLE_RE_EXTENSION */
 
@@ -590,6 +545,7 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 #  define ReREFCNT_dec(re)     SvREFCNT_dec(re)
 #  define ReREFCNT_inc(re)     ((REGEXP *) SvREFCNT_inc(re))
 #endif
+#define ReANY(re)              S_ReANY((const REGEXP *)(re))
 
 /* FIXME for plugins. */
 
diff --git a/sv.c b/sv.c
index 2a4eb6b..4c06c35 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1399,7 +1399,9 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
            SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
            IoPAGE_LEN(sv) = 60;
        }
-       if (old_type < SVt_PV) {
+       if (new_type == SVt_REGEXP)
+           sv->sv_u.svu_rx = (regexp *)new_body;
+       else if (old_type < SVt_PV) {
            /* referant will be NULL unless the old type was SVt_IV emulating
               SVt_RV */
            sv->sv_u.svu_rv = referant;
@@ -2273,7 +2275,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
        return PTR2IV(SvRV(sv));
     }
 
-    if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+    if (SvVALID(sv) || isREGEXP(sv)) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
           the same flag bit as SVf_IVisUV, so must not let them cache IVs.
           In practice they are extremely unlikely to actually get anywhere
@@ -2282,11 +2284,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
 
           Regexps have no SvIVX and SvNVX fields.
        */
-       assert(SvPOKp(sv));
+       assert(isREGEXP(sv) || SvPOKp(sv));
        {
            UV value;
+           const char * const ptr =
+               isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
            const int numtype
-               = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+               = grok_number(ptr, SvCUR(sv), &value);
 
            if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
                == IS_NUMBER_IN_UV) {
@@ -2303,7 +2307,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
                if (ckWARN(WARN_NUMERIC))
                    not_a_number(sv);
            }
-           return I_V(Atof(SvPVX_const(sv)));
+           return I_V(Atof(ptr));
        }
     }
 
@@ -2364,15 +2368,17 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
        return PTR2UV(SvRV(sv));
     }
 
-    if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+    if (SvVALID(sv) || isREGEXP(sv)) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
           the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
           Regexps have no SvIVX and SvNVX fields. */
-       assert(SvPOKp(sv));
+       assert(isREGEXP(sv) || SvPOKp(sv));
        {
            UV value;
+           const char * const ptr =
+               isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
            const int numtype
-               = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+               = grok_number(ptr, SvCUR(sv), &value);
 
            if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
                == IS_NUMBER_IN_UV) {
@@ -2384,7 +2390,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
                if (ckWARN(WARN_NUMERIC))
                    not_a_number(sv);
            }
-           return U_V(Atof(SvPVX_const(sv)));
+           return U_V(Atof(ptr));
        }
     }
 
@@ -2427,19 +2433,22 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
     dVAR;
     if (!sv)
        return 0.0;
-    if (SvGMAGICAL(sv) || SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+    if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
           the same flag bit as SVf_IVisUV, so must not let them cache NVs.
           Regexps have no SvIVX and SvNVX fields.  */
+       const char *ptr;
        if (flags & SV_GMAGIC)
            mg_get(sv);
        if (SvNOKp(sv))
            return SvNVX(sv);
        if (SvPOKp(sv) && !SvIOKp(sv)) {
+           ptr = SvPVX_const(sv);
+         grokpv:
            if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
-               !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
+               !grok_number(ptr, SvCUR(sv), NULL))
                not_a_number(sv);
-           return Atof(SvPVX_const(sv));
+           return Atof(ptr);
        }
        if (SvIOKp(sv)) {
            if (SvIsUV(sv))
@@ -2450,6 +2459,10 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
         if (SvROK(sv)) {
            goto return_rok;
        }
+       if (isREGEXP(sv)) {
+           ptr = RX_WRAPPED((REGEXP *)sv);
+           goto grokpv;
+       }
        assert(SvTYPE(sv) >= SVt_PVMG);
        /* This falls through to the report_uninit near the end of the
           function. */
@@ -2913,6 +2926,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
            *lp = SvCUR(buffer);
        return SvPVX(buffer);
     }
+    else if (isREGEXP(sv)) {
+       if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+       return RX_WRAPPED((REGEXP *)sv);
+    }
     else {
        if (lp)
            *lp = 0;
@@ -4011,8 +4028,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        break;
 
     case SVt_REGEXP:
+      upgregexp:
        if (dtype < SVt_REGEXP)
+       {
+           if (dtype >= SVt_PV) {
+               SvPV_free(dstr);
+               SvPV_set(dstr, 0);
+               SvLEN_set(dstr, 0);
+               SvCUR_set(dstr, 0);
+           }
            sv_upgrade(dstr, SVt_REGEXP);
+       }
        break;
 
        /* case SVt_BIND: */
@@ -4029,7 +4055,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                    return;
        }
        if (stype == SVt_PVLV)
+       {
+           if (isREGEXP(sstr)) goto upgregexp;
            SvUPGRADE(dstr, SVt_PVNV);
+       }
        else
            SvUPGRADE(dstr, (svtype)stype);
     }
@@ -4140,7 +4169,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
            }
        }
     }
-    else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+    else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+         && (stype == SVt_REGEXP || isREGEXP(sstr))) {
        reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
     }
     else if (sflags & SVp_POK) {
@@ -4782,12 +4812,14 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
        sv_unref_flags(sv, flags);
     else if (SvFAKE(sv) && isGV_with_GP(sv))
        sv_unglob(sv, flags);
-    else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+    else if (SvFAKE(sv) && isREGEXP(sv)) {
        /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
           to sv_unglob. We only need it here, so inline it.  */
-       const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+       const bool islv = SvTYPE(sv) == SVt_PVLV;
+       const svtype new_type =
+         islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
        SV *const temp = newSV_type(new_type);
-       void *const temp_p = SvANY(sv);
+       regexp *const temp_p = ReANY((REGEXP *)sv);
 
        if (new_type == SVt_PVMG) {
            SvMAGIC_set(temp, SvMAGIC(sv));
@@ -4795,29 +4827,37 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
            SvSTASH_set(temp, SvSTASH(sv));
            SvSTASH_set(sv, NULL);
        }
-       SvCUR_set(temp, SvCUR(sv));
-       /* Remember that SvPVX is in the head, not the body. */
-       if (SvLEN(temp)) {
-           SvLEN_set(temp, SvLEN(sv));
-           /* This signals "buffer is owned by someone else" in sv_clear,
-              which is the least effort way to stop it freeing the buffer.
-           */
-           SvLEN_set(sv, SvLEN(sv)+1);
-       } else {
-           /* Their buffer is already owned by someone else. */
-           SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
-           SvLEN_set(temp, SvCUR(sv)+1);
+       if (!islv) SvCUR_set(temp, SvCUR(sv));
+       /* Remember that SvPVX is in the head, not the body.  But
+          RX_WRAPPED is in the body. */
+       assert(ReANY((REGEXP *)sv)->mother_re);
+       /* Their buffer is already owned by someone else. */
+       if (flags & SV_COW_DROP_PV) {
+           /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
+              zeroed body.  For SVt_PVLV, it should have been set to 0
+              before turning into a regexp. */
+           assert(!SvLEN(islv ? sv : temp));
+           sv->sv_u.svu_pv = 0;
+       }
+       else {
+           sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+           SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+           SvPOK_on(sv);
        }
 
        /* Now swap the rest of the bodies. */
 
-       SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
-       SvFLAGS(sv) |= new_type;
-       SvANY(sv) = SvANY(temp);
+       SvFAKE_off(sv);
+       if (!islv) {
+           SvFLAGS(sv) &= ~SVTYPEMASK;
+           SvFLAGS(sv) |= new_type;
+           SvANY(sv) = SvANY(temp);
+       }
 
        SvFLAGS(temp) &= ~(SVTYPEMASK);
        SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
        SvANY(temp) = temp_p;
+       temp->sv_u.svu_rx = (regexp *)temp_p;
 
        SvREFCNT_dec(temp);
     }
@@ -6028,6 +6068,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
            goto freescalar;
        case SVt_REGEXP:
            /* FIXME for plugins */
+         freeregexp:
            pregfree2((REGEXP*) sv);
            goto freescalar;
        case SVt_PVCV:
@@ -6104,6 +6145,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
            }
            else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
                SvREFCNT_dec(LvTARG(sv));
+           if (isREGEXP(sv)) goto freeregexp;
        case SVt_PVGV:
            if (isGV_with_GP(sv)) {
                if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
@@ -11735,6 +11777,7 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
 {
     PERL_ARGS_ASSERT_RVPV_DUP;
 
+    assert(!isREGEXP(sstr));
     if (SvROK(sstr)) {
        if (SvWEAKREF(sstr)) {
            SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
@@ -11950,6 +11993,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 
            if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
                && !isGV_with_GP(dstr)
+               && !isREGEXP(dstr)
                && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
                Perl_rvpv_dup(aTHX_ dstr, sstr, param);
 
@@ -11978,7 +12022,9 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
            case SVt_PVMG:
                break;
            case SVt_REGEXP:
+             duprex:
                /* FIXME for plugins */
+               dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
                re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
                break;
            case SVt_PVLV:
@@ -11989,6 +12035,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
                else
                    LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+               if (isREGEXP(sstr)) goto duprex;
            case SVt_PVGV:
                /* non-GP case already handled above */
                if(isGV_with_GP(sstr)) {
diff --git a/sv.h b/sv.h
index d751be6..bd9ae1f 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -183,6 +183,7 @@ typedef struct hek HEK;
        IV      svu_iv;                 \
        UV      svu_uv;                 \
        SV*     svu_rv;         /* pointer to another SV */             \
+       struct regexp* svu_rx;          \
        SV**    svu_array;              \
        HE**    svu_hash;               \
        GP*     svu_gp;                 \
@@ -444,7 +445,12 @@ perform the upgrade if necessary.  See C<svtype>.
     HV*                xmg_stash;      /* class package */                     \
     union _xmgu        xmg_u;                                                  \
     STRLEN     xpv_cur;        /* length of svu_pv as a C string */    \
-    STRLEN     xpv_len         /* allocated size */
+    union {                                                            \
+       STRLEN  xpvlenu_len;    /* allocated size */                    \
+       char *  xpvlenu_pv;     /* regexp string */                     \
+    } xpv_len_u        
+
+#define xpv_len        xpv_len_u.xpvlenu_len
 
 union _xnvu {
     NV     xnv_nv;             /* numeric value, if any */
@@ -783,8 +789,10 @@ Set the actual length of the string which is in the SV.  See C<SvIV_set>.
 #define assert_not_glob(sv)    assert_(!isGV_with_GP(sv))
 
 #define SvOK(sv)               ((SvTYPE(sv) == SVt_BIND)               \
-                                ? (SvFLAGS(SvRV(sv)) & SVf_OK)         \
-                                : (SvFLAGS(sv) & SVf_OK))
+                                ? (SvFLAGS(SvRV(sv)) & SVf_OK          \
+                                       || isREGEXP(SvRV(sv)))          \
+                                : (SvFLAGS(sv) & SVf_OK                \
+                                        || isREGEXP(sv)))
 #define SvOK_off(sv)           (assert_not_ROK(sv) assert_not_glob(sv) \
                                 SvFLAGS(sv) &= ~(SVf_OK|               \
                                                  SVf_IVisUV|SVf_UTF8), \
@@ -1146,7 +1154,8 @@ sv_force_normal does nothing.
         }))
 #    define SvCUR(sv)                                                  \
        (*({ const SV *const _svcur = (const SV *)(sv);                 \
-           assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]);      \
+           assert(PL_valid_types_PVX[SvTYPE(_svcur) & SVt_MASK]        \
+               || SvTYPE(_svcur) == SVt_REGEXP);                       \
            assert(!isGV_with_GP(_svcur));                              \
            assert(!(SvTYPE(_svcur) == SVt_PVIO                         \
                     && !(IoFLAGS(_svcur) & IOf_FAKE_DIRP)));           \
@@ -1278,7 +1287,8 @@ sv_force_normal does nothing.
                 (((XPVMG*)  SvANY(sv))->xmg_stash = (val)); } STMT_END
 #define SvCUR_set(sv, val) \
        STMT_START { \
-               assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]);      \
+               assert(PL_valid_types_PVX[SvTYPE(sv) & SVt_MASK]        \
+                       || SvTYPE(sv) == SVt_REGEXP);   \
                assert(!isGV_with_GP(sv));              \
                assert(!(SvTYPE(sv) == SVt_PVIO         \
                     && !(IoFLAGS(sv) & IOf_FAKE_DIRP))); \
@@ -2041,6 +2051,10 @@ See also C<PL_sv_yes> and C<PL_sv_no>.
        assert (!SvIOKp(sv));                                          \
        (SvFLAGS(sv) &= ~SVpgv_GP);                                    \
     } STMT_END
+#define isREGEXP(sv) \
+    (SvTYPE(sv) == SVt_REGEXP                                \
+     || (SvFLAGS(sv) & (SVTYPEMASK|SVp_POK|SVpgv_GP|SVf_FAKE)) \
+        == (SVt_PVLV|SVf_FAKE))
 
 
 #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
index fb82d73..ac017eb 100644 (file)
--- a/t/op/qr.t
+++ b/t/op/qr.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan(tests => 24);
+plan(tests => 32);
 
 sub r {
     return qr/Good/;
@@ -82,3 +82,31 @@ ok tied $t, 'tied var is still tied after regexp assignment';
 bless \my $t2;
 $t2 = ${qr||};
 is ref \$t2, 'main', 'regexp assignment is not maledictory';
+
+{
+    my $w;
+    local $SIG{__WARN__}=sub{$w=$_[0]};
+    $_ = 1.1;
+    $_ = ${qr//};
+    is 0+$_, 0, 'double upgraded to regexp';
+    like $w, 'numeric', 'produces non-numeric warning';
+    undef $w;
+    $_ = 1;
+    $_ = ${qr//};
+    is 0+$_, 0, 'int upgraded to regexp';
+    like $w, 'numeric', 'likewise produces non-numeric warning';
+}
+
+sub {
+    $_[0] = ${qr=crumpets=};
+    is ref\$_[0], 'REGEXP', 'PVLVs';
+    # Don’t use like() here, as we would no longer be testing a PVLV.
+    ok " crumpets " =~ $_[0], 'using a regexpvlv as regexp';
+    my $x = $_[0];
+    is ref\$x, 'REGEXP', 'copying a regexpvlv';
+    $_[0] = ${qr//};
+    my $str = "".qr//;
+    $_[0] .= " ";
+    is $_[0], "$str ", 'stringifying regexpvlv in place';
+}
+ ->((\my%hash)->{key});