This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[Merge] New COW mechanism
authorFather Chrysostomos <sprout@cpan.org>
Tue, 27 Nov 2012 15:08:08 +0000 (07:08 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 27 Nov 2012 15:08:50 +0000 (07:08 -0800)
This branch makes string copying faster by introducing a new copy-on-
write mechanism.  A reference count for the string buffer is now
stored inside the string buffer itself.  This can be disabled with
-Accflags=-DPERL_NO_COW.

It also disables the PL_sawampersand mechanism, as copy-on-write
can now be used for the pre-match ‘copy’, resulting in no slow-
down from using $& and f(r)iends.  This can be reënabled with
-Accflags=-DPERL_SAWAMPERSAND.

30 files changed:
dump.c
embed.fnc
embed.h
embedvar.h
ext/Devel-Peek/t/Peek.t
gv.c
intrpvar.h
lib/English.pm
makedef.pl
op.h
perl.c
perl.h
pod/perlre.pod
pod/perlreref.pod
pod/perlretut.pod
pod/perlvar.pod
pp_ctl.c
pp_hot.c
proto.h
regcomp.c
regen/embed.pl
regexec.c
regexp.h
sv.c
sv.h
t/op/concat2.t
t/porting/test_bootstrap.t
t/re/pat_rt_report.t
t/re/subst.t
utf8.c

diff --git a/dump.c b/dump.c
index 8ba60cf..f1622a9 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1679,6 +1679,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            if (!re)
                Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
                                       (IV)SvLEN(sv));
+#ifdef PERL_NEW_COPY_ON_WRITE
+           if (SvIsCOW(sv) && SvLEN(sv))
+               Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
+                                      CowREFCNT(sv));
+#endif
        }
        else
            Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
@@ -2125,7 +2130,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                                PTR2UV(r->offs));
            Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
                                PTR2UV(r->qr_anoncv));
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
                                PTR2UV(r->saved_copy));
 #endif
index b0ed87a..e4a17b3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2239,7 +2239,7 @@ Apd       |void   |sv_copypv_flags        |NN SV *const dsv|NN SV *const ssv|const I32 flags
 Ap     |char*  |my_atof2       |NN const char *s|NN NV* value
 Apn    |int    |my_socketpair  |int family|int type|int protocol|int fd[2]
 Ap     |int    |my_dirfd       |NULLOK DIR* dir
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
 : Used in pp_hot.c and regexec.c
 pMXE   |SV*    |sv_setsv_cow   |NULLOK SV* dstr|NN SV* sstr
 #endif
diff --git a/embed.h b/embed.h
index e2c2990..c5b169d 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define dump_exec_pos(a,b,c,d,e,f)     S_dump_exec_pos(aTHX_ a,b,c,d,e,f)
 #    endif
 #  endif
+#  if defined(PERL_ANY_COW)
+#define sv_setsv_cow(a,b)      Perl_sv_setsv_cow(aTHX_ a,b)
+#  endif
 #  if defined(PERL_IN_DQUOTE_STATIC_C)
 #define grok_bslash_c(a,b,c)   S_grok_bslash_c(aTHX_ a,b,c)
 #define grok_bslash_o(a,b,c,d,e)       S_grok_bslash_o(aTHX_ a,b,c,d,e)
 #define is_utf8_X_extend(a)    Perl_is_utf8_X_extend(aTHX_ a)
 #define is_utf8_X_regular_begin(a)     Perl_is_utf8_X_regular_begin(aTHX_ a)
 #  endif
-#  if defined(PERL_OLD_COPY_ON_WRITE)
-#define sv_setsv_cow(a,b)      Perl_sv_setsv_cow(aTHX_ a,b)
-#  endif
 #endif
 #ifdef PERL_CORE
 #define Slab_Alloc(a)          Perl_Slab_Alloc(aTHX_ a)
index 0c25f34..beb3bd2 100644 (file)
 #define PL_savestack           (vTHX->Isavestack)
 #define PL_savestack_ix                (vTHX->Isavestack_ix)
 #define PL_savestack_max       (vTHX->Isavestack_max)
+#ifndef PL_sawampersand
 #define PL_sawampersand                (vTHX->Isawampersand)
+#endif
 #define PL_scopestack          (vTHX->Iscopestack)
 #define PL_scopestack_ix       (vTHX->Iscopestack_ix)
 #define PL_scopestack_max      (vTHX->Iscopestack_max)
index c9af2d2..b3dbc9b 100644 (file)
@@ -360,7 +360,8 @@ do_test('reference to regexp',
     SUBSTRS = $ADDR
     PPRIVATE = $ADDR
     OFFS = $ADDR
-    QR_ANONCV = 0x0'
+    QR_ANONCV = 0x0(?:
+    SAVED_COPY = 0x0)?'
 ));
 } else {
 do_test('reference to regexp',
@@ -529,12 +530,13 @@ do_test('scalar with pos magic',
         $x,
 'SV = PVMG\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\($PADMY,SMG,POK,pPOK\\)
+  FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
   IV = 0
   NV = 0
   PV = $ADDR ""\\\0
   CUR = 0
-  LEN = \d+
+  LEN = \d+(?:
+  COW_REFCNT = 1)?
   MAGIC = $ADDR
     MG_VIRTUAL = &PL_vtbl_mglob
     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
diff --git a/gv.c b/gv.c
index 0ec3e3a..8aa2ace 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1638,6 +1638,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                case '[':
                    require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
                     break;
+#ifdef PERL_SAWAMPERSAND
                case '`':
                    PL_sawampersand |= SAWAMPERSAND_LEFT;
                     (void)GvSVn(gv);
@@ -1650,6 +1651,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    PL_sawampersand |= SAWAMPERSAND_RIGHT;
                     (void)GvSVn(gv);
                     break;
+#endif
                 }
              }
            }
@@ -1854,6 +1856,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        case '&':               /* $& */
        case '`':               /* $` */
        case '\'':              /* $' */
+#ifdef PERL_SAWAMPERSAND
            if (!(
                sv_type == SVt_PVAV ||
                sv_type == SVt_PVHV ||
@@ -1867,6 +1870,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                                 ? SAWAMPERSAND_MIDDLE
                                 : SAWAMPERSAND_RIGHT;
                 }
+#endif
            goto magicalize;
 
        case ':':               /* $: */
index 5a6a4f1..52b45ba 100644 (file)
@@ -291,7 +291,9 @@ The C variable which corresponds to Perl's $^W warning variable.
 */
 
 PERLVAR(I, dowarn,     U8)
+#ifdef PERL_SAWAMPERSAND
 PERLVAR(I, sawampersand, U8)           /* must save all match strings */
+#endif
 PERLVAR(I, unsafe,     bool)
 PERLVAR(I, exit_flags, U8)             /* was exit() unexpected, etc. */
 
index 1f1e85d..f629068 100644 (file)
@@ -1,6 +1,6 @@
 package English;
 
-our $VERSION = '1.05';
+our $VERSION = '1.06';
 
 require Exporter;
 @ISA = qw(Exporter);
@@ -11,8 +11,9 @@ English - use nice English (or awk) names for ugly punctuation variables
 
 =head1 SYNOPSIS
 
-    use English qw( -no_match_vars ) ;  # Avoids regex performance penalty
     use English;
+    use English qw( -no_match_vars ) ;  # Avoids regex performance penalty
+                                        # in perl 5.16 and earlier
     ...
     if ($ERRNO =~ /denied/) { ... }
 
@@ -32,6 +33,10 @@ See L<perlvar> for a complete list of these.
 
 =head1 PERFORMANCE
 
+NOTE: This was fixed in perl 5.18.  Mentioning these three variables no
+longer makes a speed difference.  This section still applies if your code
+is to run on perl 5.16 or earlier.
+
 This module can provoke sizeable inefficiencies for regular expressions,
 due to unfortunate implementation details.  If performance matters in
 your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
index 9550042..0593342 100644 (file)
@@ -274,10 +274,15 @@ else {
                         );
 }
 
-unless ($define{'PERL_OLD_COPY_ON_WRITE'}) {
+unless ($define{'PERL_OLD_COPY_ON_WRITE'}
+     || $define{'PERL_NEW_COPY_ON_WRITE'}) {
     ++$skip{Perl_sv_setsv_cow};
 }
 
+unless ($define{PERL_SAW_AMPERSAND}) {
+    ++$skip{PL_sawampersand};
+}
+
 unless ($define{'USE_REENTRANT_API'}) {
     ++$skip{PL_reentrant_buffer};
 }
diff --git a/op.h b/op.h
index 935e126..97228b1 100644 (file)
--- a/op.h
+++ b/op.h
@@ -570,7 +570,8 @@ struct loop {
 #  define      cGVOPx_gv(o)    ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
 #  define      IS_PADGV(v)     (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
                                 && GvIN_PAD(v))
-#  define      IS_PADCONST(v)  (v && (SvREADONLY(v) || SvIsCOW(v)))
+#  define      IS_PADCONST(v) \
+       (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v))))
 #  define      cSVOPx_sv(v)    (cSVOPx(v)->op_sv \
                                 ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
 #  define      cSVOPx_svp(v)   (cSVOPx(v)->op_sv \
diff --git a/perl.c b/perl.c
index 0ebaeac..fe71325 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -873,7 +873,9 @@ perl_destruct(pTHXx)
     PL_minus_F      = FALSE;
     PL_doswitches   = FALSE;
     PL_dowarn       = G_WARN_OFF;
+#ifdef PERL_SAWAMPERSAND
     PL_sawampersand = 0;       /* must save all match strings */
+#endif
     PL_unsafe       = FALSE;
 
     Safefree(PL_inplace);
diff --git a/perl.h b/perl.h
index 5e28ba7..b13521a 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2494,6 +2494,18 @@ typedef AV PAD;
 typedef AV PADNAMELIST;
 typedef SV PADNAME;
 
+#if !defined(PERL_OLD_COPY_ON_WRITE) && !defined(PERL_NEW_COPY_ON_WRITE) && !defined(PERL_NO_COW)
+# define PERL_NEW_COPY_ON_WRITE
+#endif
+
+#if defined(PERL_OLD_COPY_ON_WRITE) || defined(PERL_NEW_COPY_ON_WRITE)
+# if defined(PERL_OLD_COPY_ON_WRITE) && defined(PERL_NEW_COPY_ON_WRITE)
+#  error PERL_OLD_COPY_ON_WRITE and PERL_NEW_COPY_ON_WRITE are exclusive
+# else
+#  define PERL_ANY_COW
+# endif
+#endif
+
 #include "handy.h"
 
 #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
@@ -4707,9 +4719,15 @@ EXTCONST char PL_bincompat_options[] =
 #  ifdef PERL_OLD_COPY_ON_WRITE
                             " PERL_OLD_COPY_ON_WRITE"
 #  endif
+#  ifdef PERL_NEW_COPY_ON_WRITE
+                            " PERL_NEW_COPY_ON_WRITE"
+#  endif
 #  ifdef PERL_POISON
                             " PERL_POISON"
 #  endif
+#  ifdef PERL_SAWAMPERSAND
+                            " PERL_SAWAMPERSAND"
+#  endif
 #  ifdef PERL_TRACK_MEMPOOL
                             " PERL_TRACK_MEMPOOL"
 #  endif
@@ -4897,6 +4915,11 @@ typedef enum {
 #define SAWAMPERSAND_MIDDLE     2   /* saw $& */
 #define SAWAMPERSAND_RIGHT      4   /* saw $' */
 
+#ifndef PERL_SAWAMPERSAND
+# define PL_sawampersand \
+       (SAWAMPERSAND_LEFT|SAWAMPERSAND_MIDDLE|SAWAMPERSAND_RIGHT)
+#endif
+
 /* Various states of the input record separator SV (rs) */
 #define RsSNARF(sv)   (! SvOK(sv))
 #define RsSIMPLE(sv)  (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
index 59a8abe..76b8113 100644 (file)
@@ -91,6 +91,9 @@ X</p> X<regex, preserve> X<regexp, preserve>
 Preserve the string matched such that ${^PREMATCH}, ${^MATCH}, and
 ${^POSTMATCH} are available for use after matching.
 
+In Perl 5.18 and higher this is ignored.  ${^PREMATCH}, ${^MATCH}, and
+${^POSTMATCH} will be available after the match regardless of the modifier.
+
 =item g and c
 X</g> X</c>
 
@@ -871,9 +874,11 @@ B<NOTE>: Failed matches in Perl do not reset the match variables,
 which makes it easier to write code that tests for a series of more
 specific cases and remembers the best match.
 
-B<WARNING>: Once Perl sees that you need one of C<$&>, C<$`>, or
+B<WARNING>: If your code is to run on Perl 5.16 or earlier,
+beware that once Perl sees that you need one of C<$&>, C<$`>, or
 C<$'> anywhere in the program, it has to provide them for every
-pattern match.  This may substantially slow your program.  Perl
+pattern match.  This may substantially slow your program.  (In Perl 5.18 a
+more efficient mechanism is used, eliminating any slowdown.)  Perl
 uses the same mechanism to produce C<$1>, C<$2>, etc, so you also pay a
 price for each pattern that contains capturing parentheses.  (To
 avoid this cost while retaining the grouping behaviour, use the
@@ -882,19 +887,17 @@ use C<$&>, C<$`> or C<$'>, then patterns I<without> capturing
 parentheses will not be penalized.  So avoid C<$&>, C<$'>, and C<$`>
 if you can, but if you can't (and some algorithms really appreciate
 them), once you've used them once, use them at will, because you've
-already paid the price.  As of 5.17.4, the presence of each of the three
-variables in a program is recorded separately, and depending on
-circumstances, perl may be able be more efficient knowing that only C<$&>
-rather than all three have been seen, for example.
+already paid the price. 
 X<$&> X<$`> X<$'>
 
-As a workaround for this problem, Perl 5.10.0 introduces C<${^PREMATCH}>,
+As a workaround for this problem, Perl 5.10.0 introduced C<${^PREMATCH}>,
 C<${^MATCH}> and C<${^POSTMATCH}>, which are equivalent to C<$`>, C<$&>
 and C<$'>, B<except> that they are only guaranteed to be defined after a
 successful match that was executed with the C</p> (preserve) modifier.
 The use of these variables incurs no global performance penalty, unlike
 their punctuation char equivalents, however at the trade-off that you
-have to tell perl when you want to use them.
+have to tell perl when you want to use them.  As of Perl 5.18, these three
+variables are equivalent to C<$`>, C<$&> and C<$'>, and C</p> is ignored.
 X</p> X<p modifier>
 
 =head2 Quoting metacharacters
index 954a423..83c1316 100644 (file)
@@ -275,13 +275,15 @@ There is no quantifier C<{,n}>. That's interpreted as a literal string.
    ${^MATCH}      Entire matched string
    ${^POSTMATCH}  Everything after to matched string
 
+Note to those still using Perl 5.16 or earlier:
 The use of C<$`>, C<$&> or C<$'> will slow down B<all> regex use
-within your program. Consult L<perlvar> for C<@->
-to see equivalent expressions that won't cause slow down.
-See also L<Devel::SawAmpersand>. Starting with Perl 5.10, you
+within your program.  Consult L<perlvar> for C<@->
+to see equivalent expressions that won't cause slowdown.
+See also L<Devel::SawAmpersand>.  Starting with Perl 5.10, you
 can also use the equivalent variables C<${^PREMATCH}>, C<${^MATCH}>
 and C<${^POSTMATCH}>, but for them to be defined, you have to
 specify the C</p> (preserve) modifier on your regular expression.
+In Perl 5.18, the use of C<$`>, C<$&> and C<$'> makes no speed difference.
 
    $1, $2 ...  hold the Xth captured expr
    $+    Last parenthesized pattern match
index bf4ab3b..11ad1f6 100644 (file)
@@ -900,7 +900,10 @@ of the string after the match.  An example:
 
 In the second match, C<$`> equals C<''> because the regexp matched at the
 first character position in the string and stopped; it never saw the
-second 'the'.  It is important to note that using C<$`> and C<$'>
+second 'the'.
+
+If your code is to run on Perl versions earlier than
+5.18, it is worthwhile to note that using C<$`> and C<$'>
 slows down regexp matching quite a bit, while C<$&> slows it down to a
 lesser extent, because if they are used in one regexp in a program,
 they are generated for I<all> regexps in the program.  So if raw
@@ -913,8 +916,11 @@ C<@+> instead:
     $' is the same as substr( $x, $+[0] )
 
 As of Perl 5.10, the C<${^PREMATCH}>, C<${^MATCH}> and C<${^POSTMATCH}>
-variables may be used. These are only set if the C</p> modifier is present.
-Consequently they do not penalize the rest of the program.
+variables may be used.  These are only set if the C</p> modifier is
+present.  Consequently they do not penalize the rest of the program.  In
+Perl 5.18, C<${^PREMATCH}>, C<${^MATCH}> and C<${^POSTMATCH}> are available
+whether the C</p> has been used or not (the modifier is ignored), and
+C<$`>, C<$'> and C<$&> do not cause any speed difference.
 
 =head2 Non-capturing groupings
 
index 449f3f5..2ce9e3b 100644 (file)
@@ -780,7 +780,7 @@ we have not made another match:
     $1 is Mutt; $2 is Jeff
     $1 is Wallace; $2 is Grommit
 
-Due to an unfortunate accident of Perl's implementation, C<use
+If you are using Perl v5.16 or earlier, note that C<use
 English> imposes a considerable performance penalty on all regular
 expression matches in a program because it uses the C<$`>, C<$&>, and
 C<$'>, regardless of whether they occur in the scope of C<use
@@ -797,6 +797,9 @@ Since Perl v5.10.0, you can use the C</p> match operator flag and the
 C<${^PREMATCH}>, C<${^MATCH}>, and C<${^POSTMATCH}> variables instead
 so you only suffer the performance penalties.
 
+If you are using Perl v5.18.0 or higher, you do not need to worry about
+this, as the three naughty variables are no longer naughty.
+
 =over 8
 
 =item $<I<digits>> ($1, $2, ...)
@@ -819,7 +822,8 @@ The string matched by the last successful pattern match (not counting
 any matches hidden within a BLOCK or C<eval()> enclosed by the current
 BLOCK).
 
-The use of this variable anywhere in a program imposes a considerable
+In Perl v5.16 and earlier, the use of this variable
+anywhere in a program imposes a considerable
 performance penalty on all regular expression matches.  To avoid this
 penalty, you can extract the same substring by using L</@->.  Starting
 with Perl v5.10.0, you can use the C</p> match flag and the C<${^MATCH}>
@@ -833,9 +837,11 @@ Mnemonic: like C<&> in some editors.
 X<${^MATCH}>
 
 This is similar to C<$&> (C<$MATCH>) except that it does not incur the
-performance penalty associated with that variable, and is only guaranteed
+performance penalty associated with that variable.
+In Perl v5.16 and earlier, it is only guaranteed
 to return a defined value when the pattern was compiled or executed with
-the C</p> modifier.
+the C</p> modifier.  In Perl v5.18, the C</p> modifier does nothing, so
+C<${^MATCH}> does the same thing as C<$MATCH>.
 
 This variable was added in Perl v5.10.0.
 
@@ -850,7 +856,8 @@ The string preceding whatever was matched by the last successful
 pattern match, not counting any matches hidden within a BLOCK or C<eval>
 enclosed by the current BLOCK.
 
-The use of this variable anywhere in a program imposes a considerable
+In Perl v5.16 and earlier, the use of this variable
+anywhere in a program imposes a considerable
 performance penalty on all regular expression matches.  To avoid this
 penalty, you can extract the same substring by using L</@->.  Starting
 with Perl v5.10.0, you can use the C</p> match flag and the
@@ -865,9 +872,11 @@ Mnemonic: C<`> often precedes a quoted string.
 X<$`> X<${^PREMATCH}>
 
 This is similar to C<$`> ($PREMATCH) except that it does not incur the
-performance penalty associated with that variable, and is only guaranteed
+performance penalty associated with that variable. 
+In Perl v5.16 and earlier, it is only guaranteed
 to return a defined value when the pattern was compiled or executed with
-the C</p> modifier.
+the C</p> modifier.  In Perl v5.18, the C</p> modifier does nothing, so
+C<${^PREMATCH}> does the same thing as C<$PREMATCH>.
 
 This variable was added in Perl v5.10.0
 
@@ -886,7 +895,8 @@ enclosed by the current BLOCK).  Example:
     /def/;
     print "$`:$&:$'\n";        # prints abc:def:ghi
 
-The use of this variable anywhere in a program imposes a considerable
+In Perl v5.16 and earlier, the use of this variable
+anywhere in a program imposes a considerable
 performance penalty on all regular expression matches.
 To avoid this penalty, you can extract the same substring by
 using L</@->.  Starting with Perl v5.10.0, you can use the C</p> match flag
@@ -901,9 +911,11 @@ Mnemonic: C<'> often follows a quoted string.
 X<${^POSTMATCH}> X<$'> X<$POSTMATCH>
 
 This is similar to C<$'> (C<$POSTMATCH>) except that it does not incur the
-performance penalty associated with that variable, and is only guaranteed
+performance penalty associated with that variable.
+In Perl v5.16 and earlier, it is only guaranteed
 to return a defined value when the pattern was compiled or executed with
-the C</p> modifier.
+the C</p> modifier.  In Perl v5.18, the C</p> modifier does nothing, so
+C<${^POSTMATCH}> does the same thing as C<$POSTMATCH>.
 
 This variable was added in Perl v5.10.0.
 
index c9e4ac4..f889ca8 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -354,7 +354,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     PERL_UNUSED_CONTEXT;
 
     if (!p || p[1] < RX_NPARENS(rx)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
        i = 7 + (RX_NPARENS(rx)+1) * 2;
 #else
        i = 6 + (RX_NPARENS(rx)+1) * 2;
@@ -371,7 +371,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     RX_MATCH_COPIED_off(rx);
     *p++ = RX_NPARENS(rx);
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     *p++ = PTR2UV(RX_SAVED_COPY(rx));
     RX_SAVED_COPY(rx) = NULL;
 #endif
@@ -400,7 +400,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     *p++ = 0;
     RX_NPARENS(rx) = *p++;
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     if (RX_SAVED_COPY(rx))
        SvREFCNT_dec (RX_SAVED_COPY(rx));
     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
@@ -428,14 +428,14 @@ S_rxres_free(pTHX_ void **rsp)
     if (p) {
        void *tmp = INT2PTR(char*,*p);
 #ifdef PERL_POISON
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
        U32 i = 9 + p[1] * 2;
 #else
        U32 i = 8 + p[1] * 2;
 #endif
 #endif
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
         SvREFCNT_dec (INT2PTR(SV*,p[2]));
 #endif
 #ifdef PERL_POISON
index 96b81c4..e991567 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1571,8 +1571,8 @@ yup:                                      /* Confirmed by INTUIT */
     }
     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
        I32 off;
-#ifdef PERL_OLD_COPY_ON_WRITE
-       if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+#ifdef PERL_ANY_COW
+       if (SvCANCOW(TARG)) {
            if (DEBUG_C_TEST) {
                PerlIO_printf(Perl_debug_log,
                              "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
@@ -1588,7 +1588,7 @@ yup:                                      /* Confirmed by INTUIT */
        {
 
            RX_SUBBEG(rx) = savepvn(t, strend - t);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            RX_SAVED_COPY(rx) = NULL;
 #endif
        }
@@ -2148,7 +2148,7 @@ PP(pp_subst)
     const I32 oldsave = PL_savestack_ix;
     STRLEN slen;
     bool doutf8 = FALSE; /* whether replacement is in utf8 */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     bool is_cow;
 #endif
     SV *nsv = NULL;
@@ -2167,7 +2167,7 @@ PP(pp_subst)
     }
 
     SvGETMAGIC(TARG); /* must come before cow check */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
        because they make integers such as 256 "false".  */
     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
@@ -2176,7 +2176,7 @@ PP(pp_subst)
        sv_force_normal_flags(TARG,0);
 #endif
     if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
        && !is_cow
 #endif
        && (SvREADONLY(TARG)
@@ -2284,7 +2284,7 @@ PP(pp_subst)
     
     /* can do inplace substitution? */
     if (c
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
        && !is_cow
 #endif
         && (I32)clen <= RX_MINLENRET(rx)
@@ -2294,10 +2294,11 @@ PP(pp_subst)
        && !(rpm->op_pmflags & PMf_NONDESTRUCT))
     {
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
        if (SvIsCOW(TARG)) {
-           assert (!force_on_match);
+         if (!force_on_match)
            goto have_a_cow;
+         assert(SvVOK(TARG));
        }
 #endif
        if (force_on_match) {
@@ -2390,7 +2391,7 @@ PP(pp_subst)
            s = SvPV_force_nomg(TARG, len);
            goto force_it;
        }
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
       have_a_cow:
 #endif
        if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
@@ -2456,7 +2457,7 @@ PP(pp_subst)
            SPAGAIN;
            PUSHs(dstr);
        } else {
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            /* The match may make the string COW. If so, brilliant, because
               that's just saved us one malloc, copy and free - the regexp has
               donated the old buffer, and we malloc an entirely new one, rather
diff --git a/proto.h b/proto.h
index 3089f0a..10d8889 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5235,6 +5235,13 @@ PERL_CALLCONV short      Perl_my_swap(pTHX_ short s)
 #if defined(NO_MATHOMS)
 /* PERL_CALLCONV void  Perl_sv_nounlocking(pTHX_ SV *sv); */
 #endif
+#if defined(PERL_ANY_COW)
+PERL_CALLCONV SV*      Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_SETSV_COW  \
+       assert(sstr)
+
+#endif
 #if defined(PERL_CORE)
 PERL_CALLCONV void     Perl_opslab_force_free(pTHX_ OPSLAB *slab)
                        __attribute__nonnull__(pTHX_1);
@@ -7511,13 +7518,6 @@ PERL_CALLCONV long       Perl_my_letohl(long n);
 #if defined(PERL_NEED_MY_LETOHS)
 PERL_CALLCONV short    Perl_my_letohs(short n);
 #endif
-#if defined(PERL_OLD_COPY_ON_WRITE)
-PERL_CALLCONV SV*      Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_SETSV_COW  \
-       assert(sstr)
-
-#endif
 #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C)
 STATIC void    S_pidgone(pTHX_ Pid_t pid, int status);
 #endif
index 6042a06..9903510 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -14192,7 +14192,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
        Safefree(r->substrs);
     }
     RX_MATCH_COPY_FREE(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     SvREFCNT_dec(r->saved_copy);
 #endif
     Safefree(r->offs);
@@ -14275,7 +14275,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
           anchored or float namesakes, and don't hold a second reference.  */
     }
     RX_MATCH_COPIED_off(ret_x);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     ret->saved_copy = NULL;
 #endif
     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
@@ -14483,7 +14483,7 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
        ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
     else
        ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     ret->saved_copy = NULL;
 #endif
 
@@ -14704,7 +14704,7 @@ Perl_save_re_context(pTHX)
     PL_reg_leftiter = 0;
     PL_reg_poscache = NULL;
     PL_reg_poscache_size = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     PL_nrs = NULL;
 #endif
 
index 8f59f36..b46f615 100755 (executable)
@@ -441,7 +441,13 @@ END
 my $sym;
 
 for $sym (@intrp) {
+    if ($sym eq 'sawampersand') {
+       print $em "#ifndef PL_sawampersand\n";
+    }
     print $em multon($sym,'I','vTHX->');
+    if ($sym eq 'sawampersand') {
+       print $em "#endif\n";
+    }
 }
 
 print $em <<'END';
index 6bf544e..3b2f012 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2635,9 +2635,8 @@ got_it:
     /* make sure $`, $&, $', and $digit will work later */
     if ( !(flags & REXEC_NOT_FIRST) ) {
        if (flags & REXEC_COPY_STR) {
-#ifdef PERL_OLD_COPY_ON_WRITE
-           if ((SvIsCOW(sv)
-                || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
+#ifdef PERL_ANY_COW
+           if (SvCANCOW(sv)) {
                if (DEBUG_C_TEST) {
                    PerlIO_printf(Perl_debug_log,
                                  "Copy on write: regexp capture, type %d\n",
@@ -2852,7 +2851,7 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
            PL_reg_oldsavedlen = prog->sublen;
            PL_reg_oldsavedoffset = prog->suboffset;
            PL_reg_oldsavedcoffset = prog->suboffset;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            PL_nrs = prog->saved_copy;
 #endif
            RXp_MATCH_COPIED_off(prog);
@@ -7617,7 +7616,7 @@ restore_pos(pTHX_ void *arg)
            rex->sublen = PL_reg_oldsavedlen;
            rex->suboffset = PL_reg_oldsavedoffset;
            rex->subcoffset = PL_reg_oldsavedcoffset;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            rex->saved_copy = PL_nrs;
 #endif
            RXp_MATCH_COPIED_on(rex);
index 5b07a26..8a067eb 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -46,7 +46,7 @@ struct reg_substr_data {
     struct reg_substr_datum data[3];   /* Actual array */
 };
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
 #define SV_SAVED_COPY   SV *saved_copy; /* If non-NULL, SV which is COW from original */
 #else
 #define SV_SAVED_COPY
@@ -495,7 +495,7 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 
 /* Stuff that needs to be included in the pluggable extension goes below here */
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
 #define RX_MATCH_COPY_FREE(rx) \
        STMT_START {if (RX_SAVED_COPY(rx)) { \
            SV_CHECK_THINKFIRST_COW_DROP(RX_SAVED_COPY(rx)); \
@@ -790,7 +790,7 @@ struct re_save_state {
     U32 re_state_regsize;              /* from regexec.c */
     char *re_state_reg_poscache;       /* cache of pos of WHILEM */
     char *re_state_reg_starttry;       /* from regexec.c */
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     SV *re_state_nrs;                  /* was placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012). Used to save rx->saved_copy */
 #endif
 };
diff --git a/sv.c b/sv.c
index 0a4d26f..d8d0ff8 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1502,7 +1502,10 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
 #endif
     }
     else
+    {
+       if (SvIsCOW(sv)) sv_force_normal(sv);
        s = SvPVX_mutable(sv);
+    }
 
     if (newlen > SvLEN(sv)) {          /* need more room? */
        STRLEN minlen = SvCUR(sv);
@@ -3910,6 +3913,19 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
     return;
 }
 
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+   hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(len)         ((len) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(len)         1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(len)      ((len) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(len)      1
+#endif
+
 void
 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 {
@@ -4175,6 +4191,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
     }
     else if (sflags & SVp_POK) {
         bool isSwipe = 0;
+       const STRLEN cur = SvCUR(sstr);
+       const STRLEN len = SvLEN(sstr);
 
        /*
         * Check to see if we can just swipe the string.  If so, it's a
@@ -4198,12 +4216,19 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
               source scalar is a shared hash key scalar.  */
             (((flags & SV_COW_SHARED_HASH_KEYS)
               ? !(sflags & SVf_IsCOW)
+#ifdef PERL_NEW_COPY_ON_WRITE
+               || (len &&
+                   ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
+                  /* If this is a regular (non-hek) COW, only so many COW
+                     "copies" are possible. */
+                   || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
+#endif
               : 1 /* If making a COW copy is forbidden then the behaviour we
                       desire is as if the source SV isn't actually already
                       COW, even if it is.  So we act as if the source flags
                       are not COW, rather than actually testing them.  */
              )
-#ifndef PERL_OLD_COPY_ON_WRITE
+#ifndef PERL_ANY_COW
             /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
                when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
                Conceptually PERL_OLD_COPY_ON_WRITE being defined should
@@ -4218,26 +4243,38 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
             )
             &&
             !(isSwipe =
+#ifdef PERL_NEW_COPY_ON_WRITE
+                               /* slated for free anyway (and not COW)? */
+                 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
+#else
                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
+#endif
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
                 (!(flags & SV_NOSTEAL)) &&
                                        /* and we're allowed to steal temps */
                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
-                 SvLEN(sstr))             /* and really is a string */
-#ifdef PERL_OLD_COPY_ON_WRITE
+                 len)             /* and really is a string */
+#ifdef PERL_ANY_COW
             && ((flags & SV_COW_SHARED_HASH_KEYS)
                ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+# ifdef PERL_OLD_COPY_ON_WRITE
                     && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
-                    && SvTYPE(sstr) >= SVt_PVIV))
+                    && SvTYPE(sstr) >= SVt_PVIV
+# else
+                    && !(SvFLAGS(dstr) & SVf_BREAK)
+                    && !(sflags & SVf_IsCOW)
+                    && GE_COW_THRESHOLD(cur) && cur+1 < len
+                    && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+# endif
+                   ))
                : 1)
 #endif
             ) {
             /* Failed the swipe test, and it's not a shared hash key either.
                Have to copy the string.  */
-           STRLEN len = SvCUR(sstr);
-            SvGROW(dstr, len + 1);     /* inlined from sv_setpvn */
-            Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
-            SvCUR_set(dstr, len);
+            SvGROW(dstr, cur + 1);     /* inlined from sv_setpvn */
+            Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+            SvCUR_set(dstr, cur);
             *SvEND(dstr) = '\0';
         } else {
             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
@@ -4249,13 +4286,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
             if (!isSwipe) {
                 if (!(sflags & SVf_IsCOW)) {
                     SvIsCOW_on(sstr);
+# ifdef PERL_OLD_COPY_ON_WRITE
                     /* Make the source SV into a loop of 1.
                        (about to become 2) */
                     SV_COW_NEXT_SV_SET(sstr, sstr);
+# else
+                   CowREFCNT(sstr) = 0;
+# endif
                 }
             }
 #endif
@@ -4266,15 +4307,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 
             if (!isSwipe) {
                 /* making another shared SV.  */
-                STRLEN cur = SvCUR(sstr);
-                STRLEN len = SvLEN(sstr);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
                 if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
                    assert (SvTYPE(dstr) >= SVt_PVIV);
                     /* SvIsCOW_normal */
                     /* splice us in between source and next-after-source.  */
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+                   CowREFCNT(sstr)++;
+# endif
                     SvPV_set(dstr, SvPVX_mutable(sstr));
                 } else
 #endif
@@ -4364,7 +4407,12 @@ Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
     SvSETMAGIC(dstr);
 }
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
+# ifdef PERL_OLD_COPY_ON_WRITE
+#  define SVt_COW SVt_PVIV
+# else
+#  define SVt_COW SVt_PV
+# endif
 SV *
 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
 {
@@ -4390,14 +4438,16 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     }
     else
        new_SV(dstr);
-    SvUPGRADE(dstr, SVt_PVIV);
+    SvUPGRADE(dstr, SVt_COW);
 
     assert (SvPOK(sstr));
     assert (SvPOKp(sstr));
+# ifdef PERL_OLD_COPY_ON_WRITE
     assert (!SvIOK(sstr));
     assert (!SvIOKp(sstr));
     assert (!SvNOK(sstr));
     assert (!SvNOKp(sstr));
+# endif
 
     if (SvIsCOW(sstr)) {
 
@@ -4408,21 +4458,34 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
            new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
            goto common_exit;
        }
+# ifdef PERL_OLD_COPY_ON_WRITE
        SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+# else
+       assert(SvCUR(sstr)+1 < SvLEN(sstr));
+       assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
+# endif
     } else {
        assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
-       SvUPGRADE(sstr, SVt_PVIV);
+       SvUPGRADE(sstr, SVt_COW);
        SvIsCOW_on(sstr);
        DEBUG_C(PerlIO_printf(Perl_debug_log,
                              "Fast copy on write: Converting sstr to COW\n"));
+# ifdef PERL_OLD_COPY_ON_WRITE
        SV_COW_NEXT_SV_SET(dstr, sstr);
+# else
+       CowREFCNT(sstr) = 0;    
+# endif
     }
+# ifdef PERL_OLD_COPY_ON_WRITE
     SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+    CowREFCNT(sstr)++; 
+# endif
     new_pv = SvPVX_mutable(sstr);
 
   common_exit:
     SvPV_set(dstr, new_pv);
-    SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_IsCOW);
+    SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
     if (SvUTF8(sstr))
        SvUTF8_on(dstr);
     SvLEN_set(dstr, len);
@@ -4736,29 +4799,42 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
 
     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     if (SvREADONLY(sv)) {
        if (IN_PERL_RUNTIME)
            Perl_croak_no_modify();
     }
-    else
-       if (SvIsCOW(sv)) {
-           const char * const pvx = SvPVX_const(sv);
-           const STRLEN len = SvLEN(sv);
-           const STRLEN cur = SvCUR(sv);
-           /* next COW sv in the loop.  If len is 0 then this is a shared-hash
-              key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
-              we'll fail an assertion.  */
-           SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+    else if (SvIsCOW(sv)) {
+       const char * const pvx = SvPVX_const(sv);
+       const STRLEN len = SvLEN(sv);
+       const STRLEN cur = SvCUR(sv);
+# ifdef PERL_OLD_COPY_ON_WRITE
+       /* next COW sv in the loop.  If len is 0 then this is a shared-hash
+          key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
+          we'll fail an assertion.  */
+       SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+# endif
 
-            if (DEBUG_C_TEST) {
+        if (DEBUG_C_TEST) {
                 PerlIO_printf(Perl_debug_log,
                               "Copy on write: Force normal %ld\n",
                               (long) flags);
                 sv_dump(sv);
-            }
-            SvIsCOW_off(sv);
+        }
+        SvIsCOW_off(sv);
+# ifdef PERL_NEW_COPY_ON_WRITE
+       if (len && CowREFCNT(sv) == 0)
+           /* We own the buffer ourselves. */
+           NOOP;
+       else
+# endif
+       {
+               
             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
+# ifdef PERL_NEW_COPY_ON_WRITE
+           /* Must do this first, since the macro uses SvPVX. */
+           if (len) CowREFCNT(sv)--;
+# endif
             SvPV_set(sv, NULL);
             SvLEN_set(sv, 0);
             if (flags & SV_COW_DROP_PV) {
@@ -4771,7 +4847,9 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
                 *SvEND(sv) = '\0';
             }
            if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
                sv_release_COW(sv, pvx, next);
+# endif
            } else {
                unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
            }
@@ -4779,6 +4857,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
                 sv_dump(sv);
             }
        }
+    }
 #else
     if (SvREADONLY(sv)) {
        if (IN_PERL_RUNTIME)
@@ -5299,7 +5378,7 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
     vtable = (vtable_index == magic_vtable_max)
        ? NULL : PL_magic_vtables + vtable_index;
 
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
     if (SvIsCOW(sv))
         sv_force_normal_flags(sv, 0);
 #endif
@@ -6185,7 +6264,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                        next_sv = target;
                }
            }
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
            else if (SvPVX_const(sv)
                     && !(SvTYPE(sv) == SVt_PVIO
                     && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
@@ -6196,12 +6275,23 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                        sv_dump(sv);
                    }
                    if (SvLEN(sv)) {
+# ifdef PERL_OLD_COPY_ON_WRITE
                        sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+# else
+                       if (CowREFCNT(sv)) {
+                           CowREFCNT(sv)--;
+                           SvLEN_set(sv, 0);
+                       }
+# endif
                    } else {
                        unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
                    }
 
-               } else if (SvLEN(sv)) {
+               }
+# ifdef PERL_OLD_COPY_ON_WRITE
+               else
+# endif
+               if (SvLEN(sv)) {
                    Safefree(SvPVX_mutable(sv));
                }
            }
@@ -12708,7 +12798,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
                    = pv_dup(old_state->re_state_bostr);
                new_state->re_state_regeol
                    = pv_dup(old_state->re_state_regeol);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
                new_state->re_state_nrs
                    = sv_dup(old_state->re_state_nrs, param);
 #endif
@@ -12967,7 +13057,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_minus_F         = proto_perl->Iminus_F;
     PL_doswitches      = proto_perl->Idoswitches;
     PL_dowarn          = proto_perl->Idowarn;
+#ifdef PERL_SAWAMPERSAND
     PL_sawampersand    = proto_perl->Isawampersand;
+#endif
     PL_unsafe          = proto_perl->Iunsafe;
     PL_perldb          = proto_perl->Iperldb;
     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
diff --git a/sv.h b/sv.h
index 25ceff9..cb5ac62 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1835,6 +1835,13 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
     ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), 0)
 #  define SvIsCOW_normal(sv)   (SvIsCOW(sv) && SvLEN(sv))
 #  define SvRELEASE_IVX_(sv)   SvRELEASE_IVX(sv),
+#  define SvCANCOW(sv) \
+       (SvIsCOW(sv) || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
+   on-write.  */
+#  define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+                        SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+                        SVf_OOK|SVf_BREAK|SVf_READONLY)
 #else
 #  define SvRELEASE_IVX(sv)   0
 /* This little game brought to you by the need to shut this warning up:
@@ -1842,13 +1849,26 @@ mg.c: In function 'Perl_magic_get':
 mg.c:1024: warning: left-hand operand of comma expression has no effect
 */
 #  define SvRELEASE_IVX_(sv)  /**/
+#  ifdef PERL_NEW_COPY_ON_WRITE
+#   define SvCANCOW(sv)                                            \
+       (SvIsCOW(sv)                                         \
+        ? SvLEN(sv) ? CowREFCNT(sv) != SV_COW_REFCNT_MAX : 1 \
+        : (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS       \
+                           && SvCUR(sv)+1 < SvLEN(sv))
+   /* Note: To allow 256 COW "copies", a refcnt of 0 means 1. */
+#   define CowREFCNT(sv)       (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1))
+#   define SV_COW_REFCNT_MAX   ((1 << sizeof(U8)*8) - 1)
+#   ifndef SV_COW_THRESHOLD
+#    define SV_COW_THRESHOLD   0       /* min string length for cow */
+#   endif
+#   ifndef SV_COWBUF_THRESHOLD
+#    define SV_COWBUF_THRESHOLD        1250    /* min string length for cow */
+#   endif                              /* over existing buffer */
+#   define CAN_COW_MASK        (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \
+                        SVf_OOK|SVf_BREAK|SVf_READONLY)
+#  endif
 #endif /* PERL_OLD_COPY_ON_WRITE */
 
-/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
-   on-write.  */
-#define CAN_COW_MASK   (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
-                        SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
-                        SVf_OOK|SVf_BREAK|SVf_READONLY)
 #define CAN_COW_FLAGS  (SVp_POK|SVf_POK)
 
 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \
@@ -2062,7 +2082,12 @@ See also C<PL_sv_yes> and C<PL_sv_no>.
         == (SVt_PVLV|SVf_FAKE))
 
 
-#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#ifdef PERL_NEW_COPY_ON_WRITE
+# define SvGROW(sv,len) \
+       (SvIsCOW(sv) || SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#else
+# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+#endif
 #define SvGROW_mutable(sv,len) \
     (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX_mutable(sv))
 #define Sv_Grow sv_grow
index 36b62bc..66a7d05 100644 (file)
@@ -11,7 +11,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan 2;
+plan 3;
 
 SKIP: {
 skip_if_miniperl("no dynamic loading on miniperl, no Encode", 1);
@@ -31,3 +31,25 @@ $x->[0] = "\xff";
 $x.= chr 257;
 $x.= chr 257;
 is $x, "\xff\x{101}\x{101}", '.= is not confused by changing utf8ness';
+
+# Ops should not share the same TARG between recursion levels.  This may
+# affect other ops, too, but concat seems more susceptible to this than
+# others, since it can call itself recursively.  (Where else would I put
+# this test, anyway?)
+fresh_perl_is <<'end', "tmp\ntmp\n", {},
+ sub canonpath {
+     my ($path) = @_;
+     my $node = '';
+     $path =~ s|/\z||;
+     return "$node$path";
+ }
+ {
+  package Path::Class::Dir;
+  use overload q[""] => sub { ::canonpath("tmp") };
+ }
+ print canonpath("tmp"), "\n";
+ print canonpath(bless {},"Path::Class::Dir"), "\n";
+end
+ "recursive concat does not share TARGs";
index e59feaa..654eaac 100644 (file)
@@ -49,7 +49,17 @@ while (my $file = <$fh>) {
        unless $file eq 'comp/require.t'
 }
 
-# There are regression tests using test.pl that don't want PL_sawampersand set
+# There are regression tests using test.pl that don't want PL_sawampersand
+# set.  Or at least that was the case until PL_sawampersand was disabled
+# and replaced with copy-on-write.
+
+# We still allow PL_sawampersand to be enabled with
+# -Accflags=-DPERL_SAWAMPERSAND, so when that is defined we can still run
+# these tests.  When it is not enabled, PL_sawampersand makes no observable
+# difference so the tests fail.
+
+require Config;
+exit unless "@{[Config::bincompat_options()]}" =~ /\bPERL_SAWAMPERSAND\b/;
 
 # This very much relies on a bug in the regexp implementation, but for now it's
 # the best way to work out whether PL_sawampersand is true.
index 262e8d3..d19d1df 100644 (file)
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
-plan tests => 2527;  # Update this when adding/deleting tests.
+plan tests => 2530;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1143,6 +1143,19 @@ EOP
         ok("blah blah" =~ /$pattern/, $message);
         ok("blah blah" =~ /(?:$pattern)h/, $message);
     }
+
+    {
+        # [perl #4289] First mention $& after a match
+        fresh_perl_is(
+            '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$&|, "\n"',
+            "b\n", {}, '$& first mentioned after match');
+        fresh_perl_is(
+            '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$`|, "\n"',
+            "a\n", {}, '$` first mentioned after match');
+        fresh_perl_is(
+            '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$\'|,"\n"',
+            "c\n", {}, '$\' first mentioned after match');
+    }
 } # End of sub run_tests
 
 1;
index b139812..8acd54f 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 205 );
+plan( tests => 206 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -881,3 +881,8 @@ $a = "";
 utf8::upgrade $a;
 $_ =~ s/$/$a/;
 is $_, "\xc4\x80", "empty utf8 repl does not result in mangled utf8";
+
+$@ = "\x{30cb}eval 18";
+$@ =~ s/eval \d+/eval 11/;
+is $@, "\x{30cb}eval 11",
+  'loading utf8 tables does not interfere with matches against $@';
diff --git a/utf8.c b/utf8.c
index aab7bcf..b4810f1 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2849,8 +2849,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
        method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
        if (!method) {  /* demand load utf8 */
            ENTER;
-           errsv_save = newSVsv(ERRSV);
-           SAVEFREESV(errsv_save);
+           if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+           GvSV(PL_errgv) = NULL;
            /* It is assumed that callers of this routine are not passing in
             * any user derived data.  */
            /* Need to do this after save_re_context() as it will set
@@ -2864,9 +2864,13 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
            Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
                             NULL);
            {
-               SV * const errsv = ERRSV;
-               if (!SvTRUE_NN(errsv))
-                   sv_setsv(errsv, errsv_save);
+               /* Not ERRSV, as there is no need to vivify a scalar we are
+                  about to discard. */
+               SV * const errsv = GvSV(PL_errgv);
+               if (!SvTRUE(errsv)) {
+                   GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+                   SvREFCNT_dec(errsv);
+               }
            }
            LEAVE;
        }
@@ -2879,8 +2883,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
        mPUSHi(minbits);
        mPUSHi(none);
        PUTBACK;
-       errsv_save = newSVsv(ERRSV);
-       SAVEFREESV(errsv_save);
+       if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+       GvSV(PL_errgv) = NULL;
        /* If we already have a pointer to the method, no need to use
         * call_method() to repeat the lookup.  */
        if (method
@@ -2891,9 +2895,12 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
            SvREFCNT_inc(retval);
        }
        {
-           SV * const errsv = ERRSV;
-           if (!SvTRUE_NN(errsv))
-               sv_setsv(errsv, errsv_save);
+           /* Not ERRSV.  See above. */
+           SV * const errsv = GvSV(PL_errgv);
+           if (!SvTRUE(errsv)) {
+               GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+               SvREFCNT_dec(errsv);
+           }
        }
        LEAVE;
        POPSTACK;