Change 24714 was arguably over-ambitious, in that non-core modules

can't be expected to know that sv_setsv() may now not "really" copy a
scalar. So arrange things so that COW of shared hash key scalars is
only done for calls within the the PERL_CORE.

p4raw-id: //depot/perl@29248

6 files changed, 56 insertions, 8 deletions

diff --git a/MANIFEST b/MANIFEST
index 6ae4cf2ca9..9987b37548 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1199,9 +1199,12 @@ ext/Unicode/Normalize/t/tie.t	Unicode::Normalize
 ext/util/make_ext		Used by Makefile to execute extension Makefiles
 ext/XS/APItest/APItest.pm	XS::APItest extension
 ext/XS/APItest/APItest.xs	XS::APItest extension
+ext/XS/APItest/core.c		Test API functions when PERL_CORE is defined
+ext/XS/APItest/core_or_not.inc	Code common to core.c and notcore.c
 ext/XS/APItest/exception.c	XS::APItest extension
 ext/XS/APItest/Makefile.PL	XS::APItest extension
 ext/XS/APItest/MANIFEST		XS::APItest extension
+ext/XS/APItest/notcore.c	Test API functions when PERL_CORE is not defined
 ext/XS/APItest/README		XS::APItest extension
 ext/XS/APItest/t/call.t		XS::APItest extension
 ext/XS/APItest/t/exception.t	XS::APItest extension
@@ -1210,6 +1213,7 @@ ext/XS/APItest/t/my_cxt.t	XS::APItest: test MY_CXT interface
 ext/XS/APItest/t/op.t		XS::APItest: tests for OP related APIs
 ext/XS/APItest/t/printf.t	XS::APItest extension
 ext/XS/APItest/t/push.t		XS::APItest extension
+ext/XS/APItest/t/svsetsv.t	Test behaviour of sv_setsv with/without PERL_CORE
 ext/XS/Typemap/Makefile.PL	XS::Typemap extension
 ext/XS/Typemap/README		XS::Typemap extension
 ext/XS/Typemap/stdio.c		XS::Typemap extension
diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 959125779b..668c7a94ac 100644
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -21,6 +21,7 @@ our @EXPORT = qw( print_double print_int print_long
 		  G_KEEPERR G_NODEBUG G_METHOD
 		  exception mycroak strtab
 		  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
+		  sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
 );
 
 # from cop.h 
@@ -34,7 +35,7 @@ sub G_KEEPERR()	{  16 }
 sub G_NODEBUG()	{  32 }
 sub G_METHOD()	{  64 }
 
-our $VERSION = '0.10';
+our $VERSION = '0.11';
 
 bootstrap XS::APItest $VERSION;
 
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index d83e32f216..8e9d2ffa55 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -556,3 +556,9 @@ my_cxt_setsv(sv)
 	SvREFCNT_dec(MY_CXT.sv);
 	my_cxt_setsv_p(sv _aMY_CXT);
 	SvREFCNT_inc(sv);
+
+bool
+sv_setsv_cow_hashkey_core()
+
+bool
+sv_setsv_cow_hashkey_notcore()
diff --git a/ext/XS/APItest/Makefile.PL b/ext/XS/APItest/Makefile.PL
index e49da36e08..76aa60ac35 100644
--- a/ext/XS/APItest/Makefile.PL
+++ b/ext/XS/APItest/Makefile.PL
@@ -9,7 +9,7 @@ WriteMakefile(
     ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
       (ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module
        AUTHOR     => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>') : ()),
-    'C'                 => ['exception.c'],
+    'C'                 => ['exception.c', 'core.c', 'notcore.c'],
     'OBJECT'            => '$(BASEEXT)$(OBJ_EXT) $(O_FILES)',
     'LIBS'		=> [''], # e.g., '-lm'
     'DEFINE'		=> '', # e.g., '-DHAVE_SOMETHING'
diff --git a/sv.c b/sv.c
index 66d29e480f..ad31ce15ef 100644
--- a/sv.c
+++ b/sv.c
@@ -3610,6 +3610,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 	 * possible small lose on short strings, but a big win on long ones.
 	 * It might even be a win on short strings if SvPVX_const(dstr)
 	 * has to be allocated and SvPVX_const(sstr) has to be freed.
+	 * Likewise if we can set up COW rather than doing an actual copy, we
+	 * drop to the else clause, as the swipe code and the COW setup code
+	 * have much in common.
 	 */
 
 	/* Whichever path we take through the next code, we want this true,
@@ -3617,10 +3620,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 	(void)SvPOK_only(dstr);
 
 	if (
-	    /* We're not already COW  */
-            ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+	    /* If we're already COW then this clause is not true, and if COW
+	       is allowed then we drop down to the else and make dest COW 
+	       with us.  If caller hasn't said that we're allowed to COW
+	       shared hash keys then we don't do the COW setup, even if the
+	       source scalar is a shared hash key scalar.  */
+            (((flags & SV_COW_SHARED_HASH_KEYS)
+	       ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+	       : 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
-	     /* or we are, but dstr isn't a suitable target.  */
+	     /* 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
+		override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
+		but in turn, it's somewhat dead code, never expected to go
+		live, but more kept as a placeholder on how to do it better
+		in a newer implementation.  */
+	     /* If we are COW and dstr is a suitable target then we drop down
+		into the else and make dest a COW of us.  */
 	     || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
 #endif
 	     )
diff --git a/sv.h b/sv.h
index eabc2bf59b..57911d33db 100644
--- a/sv.h
+++ b/sv.h
@@ -1679,6 +1679,21 @@ Like C<sv_catsv> but doesn't process magic.
 #define SV_MUTABLE_RETURN	64
 #define SV_SMAGIC		128
 #define SV_HAS_TRAILING_NUL	256
+#define SV_COW_SHARED_HASH_KEYS	512
+
+/* The core is safe for this COW optimisation. XS code on CPAN may not be.
+   So only default to doing the COW setup if we're in the core.
+ */
+#ifdef PERL_CORE
+#  ifndef SV_DO_COW_SVSETSV
+#    define SV_DO_COW_SVSETSV	SV_COW_SHARED_HASH_KEYS
+#  endif
+#endif
+
+#ifndef SV_DO_COW_SVSETSV
+#  define SV_DO_COW_SVSETSV	0
+#endif
+
 
 #define sv_unref(sv)    	sv_unref_flags(sv, 0)
 #define sv_force_normal(sv)	sv_force_normal_flags(sv, 0)
@@ -1720,8 +1735,9 @@ Like C<sv_catsv> but doesn't process magic.
 #define sv_pvn_force_nomg(sv, lp) sv_pvn_force_flags(sv, lp, 0)
 #define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0)
 #define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0)
-#define sv_setsv(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_GMAGIC)
-#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, 0)
+#define sv_setsv(dsv, ssv) \
+	sv_setsv_flags(dsv, ssv, SV_GMAGIC|SV_DO_COW_SVSETSV)
+#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_DO_COW_SVSETSV)
 #define sv_catsv(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC)
 #define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
 #define sv_catsv_mg(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC|SV_SMAGIC)
@@ -1828,7 +1844,7 @@ Returns a pointer to the character buffer.
 #define SvSetSV_nosteal_and(dst,src,finally) \
 	STMT_START {					\
 	    if ((dst) != (src)) {			\
-		sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL);	\
+		sv_setsv_flags(dst, src, SV_GMAGIC | SV_NOSTEAL | SV_DO_COW_SVSETSV);	\
 		finally;				\
 	    }						\
 	} STMT_END