This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement SvPVutf8_nomg and SvPVbyte_nomg
authorPali <pali@cpan.org>
Sat, 10 Feb 2018 12:41:46 +0000 (13:41 +0100)
committerTony Cook <tony@develop-help.com>
Mon, 2 Sep 2019 00:21:55 +0000 (10:21 +1000)
embed.fnc
embed.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/svpv.t
mathoms.c
proto.h
sv.c
sv.h

index 03fd8eb..0c21485 100644 (file)
--- 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 5f7cb5f..450755b 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index 132372c..d1ca8f9 100644 (file)
@@ -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:
index 4602891..4a27d29 100644 (file)
@@ -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;
+}
index 6450291..65bf267 100644 (file)
--- 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 59db1d2..63814ff 100644 (file)
--- 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 2212ba5..e591f7c 100644 (file)
--- 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 53aea18..1f24f77 100644 (file)
--- 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)