[perl #108994] Stop SvPVutf8 from coercing SVs

In shouldn’t destroy globs or references passed to it, or try to
coerce them if they are read-only or incoercible.

I added tests for SvPVbyte at the same time, even though it was not
exhibiting the same problems, as sv_utf8_downgrade doesn’t try to
coerce anything.  (SvPVbyte has its own set of bugs, which I hope to
fix in fifthcoming commits.)

diff --git a/MANIFEST b/MANIFEST
index ac9fbb0..822c9aa 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4003,6 +4003,7 @@ ext/XS-APItest/t/stuff_svcur_bug.t        test for a bug in lex_stuff_pvn
 ext/XS-APItest/t/sviscow.t     Test SvIsCOW
 ext/XS-APItest/t/svpeek.t      XS::APItest extension
 ext/XS-APItest/t/svpv_magic.t  Test behaviour of SvPVbyte and get magic
+ext/XS-APItest/t/svpv.t                More generic SvPVbyte and SvPVutf8 tests
 ext/XS-APItest/t/svsetsv.t     Test behaviour of sv_setsv with/without PERL_CORE
 ext/XS-APItest/t/swaplabel.t   test recursive descent label parsing
 ext/XS-APItest/t/swaptwostmts.t        test recursive descent statement parsing

diff --git a/embed.fnc b/embed.fnc
index 0be9b59..19b6b6b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1211,7 +1211,7 @@ Apd       |NV     |sv_2nv_flags   |NULLOK SV *const sv|const I32 flags
 pMd    |SV*    |sv_2num        |NN SV *const sv
 Amb    |char*  |sv_2pv         |NULLOK SV *sv|NULLOK STRLEN *lp
 Apd    |char*  |sv_2pv_flags   |NULLOK SV *const sv|NULLOK STRLEN *const lp|const I32 flags
-Apd    |char*  |sv_2pvutf8     |NN SV *const sv|NULLOK STRLEN *const lp
+Apd    |char*  |sv_2pvutf8     |NN SV *sv|NULLOK STRLEN *const lp
 Apd    |char*  |sv_2pvbyte     |NN SV *const sv|NULLOK STRLEN *const lp
 Ap     |char*  |sv_pvn_nomg    |NN SV* sv|NULLOK STRLEN* lp
 Amb    |UV     |sv_2uv         |NULLOK SV *sv

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 01b5b08..2c20ec2 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3273,6 +3273,20 @@ CODE:
 OUTPUT:
     RETVAL
 
+char *
+SvPVbyte(SV *sv)
+CODE:
+    RETVAL = SvPVbyte_nolen(sv);
+OUTPUT:
+    RETVAL
+
+char *
+SvPVutf8(SV *sv)
+CODE:
+    RETVAL = SvPVutf8_nolen(sv);
+OUTPUT:
+    RETVAL
+
 
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 

diff --git a/ext/XS-APItest/t/svpv.t b/ext/XS-APItest/t/svpv.t
new file mode 100644 (file)
index 0000000..e98df08
--- /dev/null
+++ b/ext/XS-APItest/t/svpv.t
@@ -0,0 +1,19 @@
+#!perl -w
+
+use Test::More tests => 16;
+
+use XS::APItest;
+
+for my $func ('SvPVbyte', 'SvPVutf8') {
+ $g = *glob;
+ $r = \1;
+ is &$func($g), '*main::glob', "$func(\$glob_copy)";
+ is ref\$g, 'GLOB', "$func(\$glob_copy) does not flatten the glob";
+ is &$func($r), "$r", "$func(\$ref)";
+ is ref\$r, 'REF', "$func(\$ref) does not flatten the ref";
+
+ is &$func(*glob), '*main::glob', "$func(*glob)";
+ is ref\$::{glob}, 'GLOB', "$func(*glob) does not flatten the glob";
+ is &$func($^V), "$^V", "$func(\$ro_ref)";
+ is ref\$^V, 'REF', "$func(\$ro_ref) does not flatten the ref";
+}

diff --git a/proto.h b/proto.h
index b5ae156..4f95c42 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3727,7 +3727,7 @@ PERL_CALLCONV char*       Perl_sv_2pvbyte(pTHX_ SV *const sv, STRLEN *const lp)
 #define PERL_ARGS_ASSERT_SV_2PVBYTE_NOLEN      \
        assert(sv)
 
-PERL_CALLCONV char*    Perl_sv_2pvutf8(pTHX_ SV *const sv, STRLEN *const lp)
+PERL_CALLCONV char*    Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_2PVUTF8    \
        assert(sv)

diff --git a/sv.c b/sv.c
index be5aec8..4b37aab 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3050,10 +3050,12 @@ Usually accessed via the C<SvPVutf8> macro.
 */
 
 char *
-Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
 {
     PERL_ARGS_ASSERT_SV_2PVUTF8;
 
+    if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
+       sv = sv_mortalcopy(sv);
     sv_utf8_upgrade(sv);
     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
 }