Implement SvPVutf8_nomg and SvPVbyte_nomg

8 files changed, 122 insertions, 15 deletions

diff --git a/embed.fnc b/embed.fnc
index 03fd8eb0bc..0c21485b3f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1606,8 +1606,10 @@ Apd	|NV	|sv_2nv_flags	|NN SV *const sv|const I32 flags
 pxd	|SV*	|sv_2num	|NN SV *const sv
 Apmb	|char*	|sv_2pv		|NN SV *sv|NULLOK STRLEN *lp
 Apd	|char*	|sv_2pv_flags	|NN SV *const sv|NULLOK STRLEN *const lp|const I32 flags
-Apd	|char*	|sv_2pvutf8	|NN SV *sv|NULLOK STRLEN *const lp
-Apd	|char*	|sv_2pvbyte	|NN SV *sv|NULLOK STRLEN *const lp
+Apdmb	|char*	|sv_2pvutf8	|NN SV *sv|NULLOK STRLEN *const lp
+Ap	|char*	|sv_2pvutf8_flags	|NN SV *sv|NULLOK STRLEN *const lp|const U32 flags
+Apdmb	|char*	|sv_2pvbyte	|NN SV *sv|NULLOK STRLEN *const lp
+Ap	|char*	|sv_2pvbyte_flags	|NN SV *sv|NULLOK STRLEN *const lp|const U32 flags
 Abp	|char*	|sv_pvn_nomg	|NN SV* sv|NULLOK STRLEN* lp
 Apmb	|UV	|sv_2uv		|NN SV *sv
 Apd	|UV	|sv_2uv_flags	|NN SV *const sv|const I32 flags
diff --git a/embed.h b/embed.h
index 5f7cb5f58f..450755b912 100644
--- a/embed.h
+++ b/embed.h
@@ -726,8 +726,8 @@
 #define sv_2mortal(a)		Perl_sv_2mortal(aTHX_ a)
 #define sv_2nv_flags(a,b)	Perl_sv_2nv_flags(aTHX_ a,b)
 #define sv_2pv_flags(a,b,c)	Perl_sv_2pv_flags(aTHX_ a,b,c)
-#define sv_2pvbyte(a,b)		Perl_sv_2pvbyte(aTHX_ a,b)
-#define sv_2pvutf8(a,b)		Perl_sv_2pvutf8(aTHX_ a,b)
+#define sv_2pvbyte_flags(a,b,c)	Perl_sv_2pvbyte_flags(aTHX_ a,b,c)
+#define sv_2pvutf8_flags(a,b,c)	Perl_sv_2pvutf8_flags(aTHX_ a,b,c)
 #define sv_2uv_flags(a,b)	Perl_sv_2uv_flags(aTHX_ a,b)
 #define sv_backoff		Perl_sv_backoff
 #define sv_bless(a,b)		Perl_sv_bless(aTHX_ a,b)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 132372c752..d1ca8f94b3 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4219,12 +4219,26 @@ OUTPUT:
     RETVAL
 
 char *
+SvPVbyte_nomg(SV *sv)
+CODE:
+    RETVAL = SvPVbyte_nomg(sv, PL_na);
+OUTPUT:
+    RETVAL
+
+char *
 SvPVutf8(SV *sv)
 CODE:
     RETVAL = SvPVutf8_nolen(sv);
 OUTPUT:
     RETVAL
 
+char *
+SvPVutf8_nomg(SV *sv)
+CODE:
+    RETVAL = SvPVutf8_nomg(sv, PL_na);
+OUTPUT:
+    RETVAL
+
 void
 setup_addissub()
 CODE:
diff --git a/ext/XS-APItest/t/svpv.t b/ext/XS-APItest/t/svpv.t
index 4602891405..4a27d29729 100644
--- a/ext/XS-APItest/t/svpv.t
+++ b/ext/XS-APItest/t/svpv.t
@@ -1,6 +1,6 @@
 #!perl -w
 
-use Test::More tests => 19;
+use Test::More tests => 35;
 
 use XS::APItest;
 
@@ -18,6 +18,32 @@ for my $func ('SvPVbyte', 'SvPVutf8') {
  is ref\$^V, 'REF', "$func(\$ro_ref) does not flatten the ref";
 }
 
+my $data_bin = "\xC4\x8D";
+utf8::downgrade($data_bin);
+tie my $scalar_bin, 'TieScalarCounter', $data_bin;
+do { my $fetch = $scalar_bin };
+is tied($scalar_bin)->{fetch}, 1;
+is tied($scalar_bin)->{store}, 0;
+is SvPVutf8_nomg($scalar_bin), "\xC3\x84\xC2\x8D";
+is tied($scalar_bin)->{fetch}, 1;
+is tied($scalar_bin)->{store}, 0;
+is SvPVbyte_nomg($scalar_bin), "\xC4\x8D";
+is tied($scalar_bin)->{fetch}, 1;
+is tied($scalar_bin)->{store}, 0;
+
+my $data_uni = "\xC4\x8D";
+utf8::upgrade($data_uni);
+tie my $scalar_uni, 'TieScalarCounter', $data_uni;
+do { my $fetch = $scalar_uni };
+is tied($scalar_uni)->{fetch}, 1;
+is tied($scalar_uni)->{store}, 0;
+is SvPVbyte_nomg($scalar_uni), "\xC4\x8D";
+is tied($scalar_uni)->{fetch}, 1;
+is tied($scalar_uni)->{store}, 0;
+is SvPVutf8_nomg($scalar_uni), "\xC3\x84\xC2\x8D";
+is tied($scalar_uni)->{fetch}, 1;
+is tied($scalar_uni)->{store}, 0;
+
 eval 'SvPVbyte(*{chr 256})';
 like $@, qr/^Wide character/, 'SvPVbyte fails on Unicode glob';
 package r { use overload '""' => sub { substr "\x{100}\xff", -1 } }
@@ -29,3 +55,22 @@ sub FETCH { ${ +shift } }
 tie $tyre, main => bless [], r::;
 is SvPVbyte($tyre), "\xff",
   'SvPVbyte on tie returning ref that returns downgradable utf8 string';
+
+package TieScalarCounter;
+
+sub TIESCALAR {
+    my ($class, $value) = @_;
+    return bless { fetch => 0, store => 0, value => $value }, $class;
+}
+
+sub FETCH {
+    my ($self) = @_;
+    $self->{fetch}++;
+    return $self->{value};
+}
+
+sub STORE {
+    my ($self, $value) = @_;
+    $self->{store}++;
+    $self->{value} = $value;
+}
diff --git a/mathoms.c b/mathoms.c
index 6450291317..65bf267943 100644
--- a/mathoms.c
+++ b/mathoms.c
@@ -1769,6 +1769,22 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
     return sv_utf8_downgrade(sv, fail_ok);
 }
 
+char *
+Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
+{
+    PERL_ARGS_ASSERT_SV_2PVUTF8;
+
+    return sv_2pvutf8(sv, lp);
+}
+
+char *
+Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
+{
+    PERL_ARGS_ASSERT_SV_2PVBYTE;
+
+    return sv_2pvbyte(sv, lp);
+}
+
 #endif /* NO_MATHOMS */
 
 /*
diff --git a/proto.h b/proto.h
index 59db1d214f..63814ff1b1 100644
--- a/proto.h
+++ b/proto.h
@@ -3232,9 +3232,14 @@ PERL_CALLCONV char*	Perl_sv_2pv_nolen(pTHX_ SV* sv)
 	assert(sv)
 #endif
 
+#ifndef NO_MATHOMS
 PERL_CALLCONV char*	Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp);
 #define PERL_ARGS_ASSERT_SV_2PVBYTE	\
 	assert(sv)
+#endif
+PERL_CALLCONV char*	Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
+#define PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS	\
+	assert(sv)
 #ifndef NO_MATHOMS
 PERL_CALLCONV char*	Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
 			__attribute__warn_unused_result__;
@@ -3242,9 +3247,14 @@ PERL_CALLCONV char*	Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
 	assert(sv)
 #endif
 
+#ifndef NO_MATHOMS
 PERL_CALLCONV char*	Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp);
 #define PERL_ARGS_ASSERT_SV_2PVUTF8	\
 	assert(sv)
+#endif
+PERL_CALLCONV char*	Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
+#define PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS	\
+	assert(sv)
 #ifndef NO_MATHOMS
 PERL_CALLCONV char*	Perl_sv_2pvutf8_nolen(pTHX_ SV* sv)
 			__attribute__warn_unused_result__;
diff --git a/sv.c b/sv.c
index 2212ba57a1..e591f7c60c 100644
--- a/sv.c
+++ b/sv.c
@@ -3322,18 +3322,19 @@ Usually accessed via the C<SvPVbyte> macro.
 */
 
 char *
-Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
+Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
 {
-    PERL_ARGS_ASSERT_SV_2PVBYTE;
+    PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
 
-    SvGETMAGIC(sv);
+    if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+        mg_get(sv);
     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
      || isGV_with_GP(sv) || SvROK(sv)) {
 	SV *sv2 = sv_newmortal();
 	sv_copypv_nomg(sv2,sv);
 	sv = sv2;
     }
-    sv_utf8_downgrade(sv,0);
+    sv_utf8_downgrade_nomg(sv,0);
     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
 }
 
@@ -3349,15 +3350,18 @@ Usually accessed via the C<SvPVutf8> macro.
 */
 
 char *
-Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
+Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
 {
-    PERL_ARGS_ASSERT_SV_2PVUTF8;
+    PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
 
+    if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+        mg_get(sv);
     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
-     || isGV_with_GP(sv) || SvROK(sv))
-	sv = sv_mortalcopy(sv);
-    else
-        SvGETMAGIC(sv);
+     || isGV_with_GP(sv) || SvROK(sv)) {
+        SV *sv2 = sv_newmortal();
+        sv_copypv_nomg(sv2,sv);
+        sv = sv2;
+    }
     sv_utf8_upgrade_nomg(sv);
     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
 }
diff --git a/sv.h b/sv.h
index 53aea18aeb..1f24f773a0 100644
--- a/sv.h
+++ b/sv.h
@@ -1622,6 +1622,9 @@ Like C<SvPV_force>, but converts C<sv> to UTF-8 first if necessary.
 =for apidoc Am|char*|SvPVutf8|SV* sv|STRLEN len
 Like C<SvPV>, but converts C<sv> to UTF-8 first if necessary.
 
+=for apidoc Am|char*|SvPVutf8_nomg|SV* sv|STRLEN len
+Like C<SvPVutf8>, but does not process get magic.
+
 =for apidoc Am|char*|SvPVutf8_nolen|SV* sv
 Like C<SvPV_nolen>, but converts C<sv> to UTF-8 first if necessary.
 
@@ -1631,6 +1634,9 @@ Like C<SvPV_force>, but converts C<sv> to byte representation first if necessary
 =for apidoc Am|char*|SvPVbyte|SV* sv|STRLEN len
 Like C<SvPV>, but converts C<sv> to byte representation first if necessary.
 
+=for apidoc Am|char*|SvPVbyte_nomg|SV* sv|STRLEN len
+Like C<SvPVbyte>, but does not process get magic.
+
 =for apidoc Am|char*|SvPVbyte_nolen|SV* sv
 Like C<SvPV_nolen>, but converts C<sv> to byte representation first if necessary.
 
@@ -1752,6 +1758,10 @@ Like C<sv_catsv> but doesn't process magic.
     (SvPOK_utf8_nog(sv) \
      ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
 
+#define SvPVutf8_nomg(sv, lp) \
+    (SvPOK_utf8_nog(sv) \
+     ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+
 #define SvPVutf8_force(sv, lp) \
     (SvPOK_utf8_pure_nogthink(sv) \
      ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1766,6 +1776,10 @@ Like C<sv_catsv> but doesn't process magic.
     (SvPOK_byte_nog(sv) \
      ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
 
+#define SvPVbyte_nomg(sv, lp) \
+    (SvPOK_byte_nog(sv) \
+     ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+
 #define SvPVbyte_force(sv, lp) \
     (SvPOK_byte_pure_nogthink(sv) \
      ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
@@ -1957,7 +1971,9 @@ Like C<sv_catsv> but doesn't process magic.
 #define sv_copypv_nomg(dsv, ssv) sv_copypv_flags(dsv, ssv, 0)
 #define sv_2pv(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC)
 #define sv_2pv_nolen(sv) sv_2pv(sv, 0)
+#define sv_2pvbyte(sv, lp) sv_2pvbyte_flags(sv, lp, SV_GMAGIC)
 #define sv_2pvbyte_nolen(sv) sv_2pvbyte(sv, 0)
+#define sv_2pvutf8(sv, lp) sv_2pvutf8_flags(sv, lp, SV_GMAGIC)
 #define sv_2pvutf8_nolen(sv) sv_2pvutf8(sv, 0)
 #define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0)
 #define sv_pvn_force(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC)