[perl #79824] Don’t cow for sv_mortalcopy call from XS

XS code doing sv_mortalcopy(sv) will expect to get a true copy, and
not a COW ‘copy’.

So make sv_mortalcopy and wrapper around the new sv_mortalcopy_flags
that passes it SV_DO_COW_SVSETSV, which is defined as 0 for XS code.

diff --git a/embed.fnc b/embed.fnc
index 555114f..3bd03e8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1314,7 +1314,8 @@ Apd       |void   |sv_magic       |NN SV *const sv|NULLOK SV *const obj|const int how \
 Apd    |MAGIC *|sv_magicext    |NN SV *const sv|NULLOK SV *const obj|const int how \
                                |NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \
                                |const I32 namlen
-ApdaR  |SV*    |sv_mortalcopy  |NULLOK SV *const oldsv
+ApdbamR        |SV*    |sv_mortalcopy  |NULLOK SV *const oldsv
+XpaR   |SV*    |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags
 ApdR   |SV*    |sv_newmortal
 Apd    |SV*    |sv_newref      |NULLOK SV *const sv
 Ap     |char*  |sv_peek        |NULLOK SV* sv

diff --git a/embed.h b/embed.h
index 7146cec..6949461 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -588,7 +588,6 @@
 #define sv_len_utf8(a)         Perl_sv_len_utf8(aTHX_ a)
 #define sv_magic(a,b,c,d,e)    Perl_sv_magic(aTHX_ a,b,c,d,e)
 #define sv_magicext(a,b,c,d,e,f)       Perl_sv_magicext(aTHX_ a,b,c,d,e,f)
-#define sv_mortalcopy(a)       Perl_sv_mortalcopy(aTHX_ a)
 #define sv_newmortal()         Perl_sv_newmortal(aTHX)
 #define sv_newref(a)           Perl_sv_newref(aTHX_ a)
 #define sv_nosharing(a)                Perl_sv_nosharing(aTHX_ a)
@@ -1202,6 +1201,7 @@
 #define sv_del_backref(a,b)    Perl_sv_del_backref(aTHX_ a,b)
 #define sv_free_arenas()       Perl_sv_free_arenas(aTHX)
 #define sv_len_utf8_nomg(a)    Perl_sv_len_utf8_nomg(aTHX_ a)
+#define sv_mortalcopy_flags(a,b)       Perl_sv_mortalcopy_flags(aTHX_ a,b)
 #define sv_ref(a,b,c)          Perl_sv_ref(aTHX_ a,b,c)
 #define sv_resetpvn(a,b,c)     Perl_sv_resetpvn(aTHX_ a,b,c)
 #define sv_sethek(a,b)         Perl_sv_sethek(aTHX_ a,b)

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 1d2f6f3..a8ce71d 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3452,6 +3452,12 @@ lexical_import(SV *name, CV *cv)
        LEAVE;
     }
 
+SV *
+sv_mortalcopy(SV *sv)
+    CODE:
+       RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
+    OUTPUT:
+       RETVAL
 
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 

diff --git a/ext/XS-APItest/t/svsetsv.t b/ext/XS-APItest/t/svsetsv.t
index 328bc77..68e8cd6 100644 (file)
--- a/ext/XS-APItest/t/svsetsv.t
+++ b/ext/XS-APItest/t/svsetsv.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 7;
 
 BEGIN { use_ok('XS::APItest') };
 
@@ -20,3 +20,8 @@ foo(\1); sv_set_deref(\&AUTOLOAD, '$', 1);
 is prototype(\&AUTOLOAD), '$', 'sv_setpv(cv,...) sets prototype';
 foo(\1); sv_set_deref(\&AUTOLOAD, '$', 2);
 is prototype(\&AUTOLOAD), '$', 'sv_setpvn(cv,...) sets prototype';
+
+# Perhaps this does not belong here?  But it is at least testing that
+# sv_mortalcopy uses sv_setsv in an unsurprising way.
+ok !SvIsCOW(sv_mortalcopy(__PACKAGE__)),
+  'sv_mortalcopy does not COW for extensions [perl #79824]';

diff --git a/mathoms.c b/mathoms.c
index 7f49863..a29f70c 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -93,6 +93,7 @@ PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV UV Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV UV Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV UV Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV SV *Perl_sv_mortalcopy(pTHX_ SV *const oldstr);
 
 /* ref() is now a macro using Perl_doref;
  * this version provided for binary compatibility only.
@@ -1202,6 +1203,12 @@ Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
     return _to_utf8_upper_flags(p, ustrp, lenp, FALSE, NULL);
 }
 
+SV *
+Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+{
+    Perl_sv_mortalcopy_flags(aTHX_ oldstr, SV_GMAGIC);
+}
+
 END_EXTERN_C
 
 #endif /* NO_MATHOMS */

diff --git a/proto.h b/proto.h
index 55c4d56..80f252e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3998,7 +3998,11 @@ PERL_CALLCONV MAGIC *    Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const
 #define PERL_ARGS_ASSERT_SV_MAGICEXT   \
        assert(sv)
 
-PERL_CALLCONV SV*      Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
+/* PERL_CALLCONV SV*   Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
+                       __attribute__malloc__
+                       __attribute__warn_unused_result__; */
+
+PERL_CALLCONV SV*      Perl_sv_mortalcopy_flags(pTHX_ SV *const oldsv, U32 flags)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
 

diff --git a/sv.c b/sv.c
index 375a119..850f0b7 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8225,13 +8225,13 @@ statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
  * permanent location. */
 
 SV *
-Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
 {
     dVAR;
     SV *sv;
 
     new_SV(sv);
-    sv_setsv(sv,oldstr);
+    sv_setsv_flags(sv,oldstr,flags);
     PUSH_EXTEND_MORTAL__SV_C(sv);
     SvTEMP_on(sv);
     return sv;

diff --git a/sv.h b/sv.h
index b839a63..69a7380 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1805,6 +1805,8 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #define sv_insert(bigstr, offset, len, little, littlelen)              \
        Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little),  \
                             (littlelen), SV_GMAGIC)
+#define sv_mortalcopy(sv) \
+       Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV)
 
 /* Should be named SvCatPVN_utf8_upgrade? */
 #define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv)      \