Implement sv_utf8_downgrade_nomg

diff --git a/embed.fnc b/embed.fnc
index c373205..03fd8eb 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2114,7 +2114,9 @@ ApmdbR    |char*  |sv_pvutf8      |NN SV *sv
 ApmdbR |char*  |sv_pvbyte      |NN SV *sv
 Apmdb  |STRLEN |sv_utf8_upgrade|NN SV *sv
 Amd    |STRLEN |sv_utf8_upgrade_nomg|NN SV *sv
-Apd    |bool   |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+Apdmb  |bool   |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+Amd    |bool   |sv_utf8_downgrade_nomg|NN SV *const sv|const bool fail_ok
+Apd    |bool   |sv_utf8_downgrade_flags|NN SV *const sv|const bool fail_ok|const U32 flags
 Apd    |void   |sv_utf8_encode |NN SV *const sv
 Apd    |bool   |sv_utf8_decode |NN SV *const sv
 Apdmb  |void   |sv_force_normal|NN SV *sv

diff --git a/embed.h b/embed.h
index 7865923..5f7cb5f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -854,7 +854,7 @@
 #define sv_upgrade(a,b)                Perl_sv_upgrade(aTHX_ a,b)
 #define sv_usepvn_flags(a,b,c,d)       Perl_sv_usepvn_flags(aTHX_ a,b,c,d)
 #define sv_utf8_decode(a)      Perl_sv_utf8_decode(aTHX_ a)
-#define sv_utf8_downgrade(a,b) Perl_sv_utf8_downgrade(aTHX_ a,b)
+#define sv_utf8_downgrade_flags(a,b,c) Perl_sv_utf8_downgrade_flags(aTHX_ a,b,c)
 #define sv_utf8_encode(a)      Perl_sv_utf8_encode(aTHX_ a)
 #define sv_utf8_upgrade_flags_grow(a,b,c)      Perl_sv_utf8_upgrade_flags_grow(aTHX_ a,b,c)
 #ifndef NO_MATHOMS

diff --git a/mathoms.c b/mathoms.c
index e2dc11c..6450291 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -1761,6 +1761,14 @@ Perl_newSVsv(pTHX_ SV *const old)
     return newSVsv(old);
 }
 
+bool
+Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
+{
+    PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+
+    return sv_utf8_downgrade(sv, fail_ok);
+}
+
 #endif /* NO_MATHOMS */
 
 /*

diff --git a/proto.h b/proto.h
index 29a1e0c..59db1d2 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3701,9 +3701,15 @@ PERL_CALLCONV void       Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len);
 PERL_CALLCONV bool     Perl_sv_utf8_decode(pTHX_ SV *const sv);
 #define PERL_ARGS_ASSERT_SV_UTF8_DECODE        \
        assert(sv)
+#ifndef NO_MATHOMS
 PERL_CALLCONV bool     Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok);
 #define PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE     \
        assert(sv)
+#endif
+PERL_CALLCONV bool     Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags);
+#define PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS       \
+       assert(sv)
+/* PERL_CALLCONV bool  sv_utf8_downgrade_nomg(pTHX_ SV *const sv, const bool fail_ok); */
 PERL_CALLCONV void     Perl_sv_utf8_encode(pTHX_ SV *const sv);
 #define PERL_ARGS_ASSERT_SV_UTF8_ENCODE        \
        assert(sv)

diff --git a/sv.c b/sv.c
index df0b601..2212ba5 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3649,19 +3649,31 @@ true, croaks.
 This is not a general purpose Unicode to byte encoding interface:
 use the C<Encode> extension for that.
 
+This function process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_nomg
+
+Like C<sv_utf8_downgrade>, but does not process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_flags
+
+Like C<sv_utf8_downgrade>, but with additional C<flags>.
+If C<flags> has C<SV_GMAGIC> bit set, then this function process
+get magic on C<sv>.
+
 =cut
 */
 
 bool
-Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
+Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
 {
-    PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+    PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
 
     if (SvPOKp(sv) && SvUTF8(sv)) {
         if (SvCUR(sv)) {
            U8 *s;
            STRLEN len;
-           int mg_flags = SV_GMAGIC;
+            U32 mg_flags = flags & SV_GMAGIC;
 
             if (SvIsCOW(sv)) {
                 S_sv_uncow(aTHX_ sv, 0);
@@ -3671,7 +3683,7 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
                MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
                if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
                        mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
-                                               SV_GMAGIC|SV_CONST_RETURN);
+                                               mg_flags|SV_CONST_RETURN);
                        mg_flags = 0; /* sv_pos_b2u does get magic */
                }
                if ((mg = mg_find(sv, PERL_MAGIC_utf8)))

diff --git a/sv.h b/sv.h
index 24c728d..53aea18 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1941,6 +1941,8 @@ 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_flags(sv, flags) sv_utf8_upgrade_flags_grow(sv, flags, 0)
 #define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0)
+#define sv_utf8_downgrade(sv, fail_ok) sv_utf8_downgrade_flags(sv, fail_ok, SV_GMAGIC)
+#define sv_utf8_downgrade_nomg(sv, fail_ok) sv_utf8_downgrade_flags(sv, fail_ok, 0)
 #define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0)
 #define sv_catpv_nomg(dsv, sstr) sv_catpv_flags(dsv, sstr, 0)
 #define sv_setsv(dsv, ssv) \