Missing SvPV* utf8/byte nomg macro variants #16392
Comments
From @paliHi! Currently in perl there are missing SvPVutf8_nomg and SvPVbyte_nomg Currently for API which accepts undef or string is required something void Which is really non-intuitive and hard to write from scratch for novice With SvPVutf8_nomg it would reduce code just to: void Maybe some SvPV* macro which would return NULL without warning for Also, perlapi documentation should suggest to use SvPVutf8 (reps. Also, to prevent processing get magic more times, it is needed to call |
From @khwilliamsonPatches welcome :) |
|
The RT System itself - Status changed from 'new' to 'open' |
From @paliOn Wednesday 31 January 2018 06:48:21 Karl Williamson via RT wrote:
What about something like this? #ifndef SvPVutf8_nomg #ifndef SvPVbyte_nomg |
From @paliIn attachment are RFC patches for new functions/macros: sv_utf8_downgrade_flags() sv_2pvbyte_flags() SvPVutf8_nomg() SvPV_or_null() SvPVutf8_or_null() SvPVbyte_or_null() What about them? |
From @pali0001-Implement-sv_utf8_downgrade_nomg.patchFrom a2b03965498f57448e06d54a1ef4e26a7302593c Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [RFC PATCH 1/4] Implement sv_utf8_downgrade_nomg
---
embed.h | 2 +-
proto.h | 2 +-
sv.c | 9 ++++++---
sv.h | 2 ++
4 files changed, 10 insertions(+), 5 deletions(-)
diff --git a/embed.h b/embed.h
index d1fe34ab66..7df5dfdd52 100644
--- a/embed.h
+++ b/embed.h
@@ -703,7 +703,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)
#define sv_uv(a) Perl_sv_uv(aTHX_ a)
diff --git a/proto.h b/proto.h
index 485211540b..e6b52c925e 100644
--- a/proto.h
+++ b/proto.h
@@ -3466,7 +3466,7 @@ 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)
-PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok);
+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 \
assert(sv)
PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *const sv);
diff --git a/sv.c b/sv.c
index fa5295d4ba..6937222aae 100644
--- a/sv.c
+++ b/sv.c
@@ -3598,7 +3598,7 @@ use the C<Encode> extension for that.
*/
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;
@@ -3606,7 +3606,10 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
- int mg_flags = SV_GMAGIC;
+ int mg_flags = 0;
+
+ if (flags & SV_GMAGIC)
+ mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
@@ -3616,7 +3619,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 1c7224277f..05aa924f76 100644
--- a/sv.h
+++ b/sv.h
@@ -1919,6 +1919,8 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
#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) \
--
2.11.0
|
From @pali0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom 58f6ccda8f161c8ace9aabed4305ba9e3580fe3f Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [RFC PATCH 2/4] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 7cc227faac..399a573d7a 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @pali0003-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom c5cbcce771edadf1fc261e4e0f2de8c2e6482df6 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [RFC PATCH 3/4] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.h | 4 ++--
proto.h | 4 ++--
sv.c | 20 ++++++++++++--------
sv.h | 10 ++++++++++
4 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/embed.h b/embed.h
index 7df5dfdd52..a6a3be73f1 100644
--- a/embed.h
+++ b/embed.h
@@ -588,8 +588,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/proto.h b/proto.h
index e6b52c925e..9f426debf7 100644
--- a/proto.h
+++ b/proto.h
@@ -3011,7 +3011,7 @@ PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp);
+PERL_CALLCONV char* Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
#define PERL_ARGS_ASSERT_SV_2PVBYTE \
assert(sv)
#ifndef NO_MATHOMS
@@ -3021,7 +3021,7 @@ PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp);
+PERL_CALLCONV char* Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
assert(sv)
#ifndef NO_MATHOMS
diff --git a/sv.c b/sv.c
index 6937222aae..6f297e600e 100644
--- a/sv.c
+++ b/sv.c
@@ -3268,18 +3268,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;
- 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);
}
@@ -3295,15 +3296,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;
+ 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 05aa924f76..bf4ab9bb5c 100644
--- a/sv.h
+++ b/sv.h
@@ -1730,6 +1730,10 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
(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))
@@ -1744,6 +1748,10 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
(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))
@@ -1935,7 +1943,9 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
#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)
--
2.11.0
|
From @pali0004-Implement-SvPV-_or_null.patchFrom 8e9bc41cd5a3176442023d67cf90ead64e3f9016 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [RFC PATCH 4/4] Implement SvPV*_or_null*
---
sv.h | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
diff --git a/sv.h b/sv.h
index bf4ab9bb5c..8199f572d5 100644
--- a/sv.h
+++ b/sv.h
@@ -1670,6 +1670,7 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
#define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
+#define SvPV_or_null(sv, lp) (SvGETMAGIC(sv), SvPV_or_null_nomg(sv, lp))
#define SvPV_flags(sv, lp, flags) \
(SvPOK_nog(sv) \
@@ -1723,6 +1724,7 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
#define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
#define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
#define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
+#define SvPV_or_null_nomg(sv, lp) (SvOK(sv) ? SvPV_nomg(sv, lp) : ((lp = 0), NULL))
/* ----*/
@@ -1730,10 +1732,20 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1748,10 +1760,20 @@ Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @paliOn Sunday 11 February 2018 12:44:31 pali@cpan.org wrote:
Hello, can somebody comment / review these patches? |
From @paliIn attachment are rebased patches on current blead. |
From @paliv2-0001-Implement-sv_utf8_downgrade_nomg.patchFrom c91c1eab30be09f24654805f4472dd11f7b26787 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH 1/4] Implement sv_utf8_downgrade_nomg
---
embed.h | 2 +-
proto.h | 2 +-
sv.c | 9 ++++++---
sv.h | 2 ++
4 files changed, 10 insertions(+), 5 deletions(-)
diff --git a/embed.h b/embed.h
index 8e762bc248..c82799b75b 100644
--- a/embed.h
+++ b/embed.h
@@ -850,7 +850,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/proto.h b/proto.h
index 0e6c76a3bc..5bb7194698 100644
--- a/proto.h
+++ b/proto.h
@@ -3652,7 +3652,7 @@ 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)
-PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok);
+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 \
assert(sv)
PERL_CALLCONV void Perl_sv_utf8_encode(pTHX_ SV *const sv);
diff --git a/sv.c b/sv.c
index 77f63183f7..abb1ed4a10 100644
--- a/sv.c
+++ b/sv.c
@@ -3600,7 +3600,7 @@ use the C<Encode> extension for that.
*/
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;
@@ -3608,7 +3608,10 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
- int mg_flags = SV_GMAGIC;
+ int mg_flags = 0;
+
+ if (flags & SV_GMAGIC)
+ mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
@@ -3618,7 +3621,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 f3392b08ec..4bf948f6d7 100644
--- a/sv.h
+++ b/sv.h
@@ -1915,6 +1915,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) \
--
2.11.0
|
From @paliv2-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom c7ee9830d6a45c7ecaa8a38d97f9da287d7ad2f1 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH 2/4] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 54e35f10a6..febff6e217 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv2-0003-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom 6a70a3ac23f50777aae98f0b0c938fcfa45f33a8 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH 3/4] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.h | 4 ++--
proto.h | 4 ++--
sv.c | 20 ++++++++++++--------
sv.h | 10 ++++++++++
4 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/embed.h b/embed.h
index c82799b75b..1fb183561e 100644
--- a/embed.h
+++ b/embed.h
@@ -723,8 +723,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/proto.h b/proto.h
index 5bb7194698..eeb496ba5f 100644
--- a/proto.h
+++ b/proto.h
@@ -3183,7 +3183,7 @@ PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp);
+PERL_CALLCONV char* Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
#define PERL_ARGS_ASSERT_SV_2PVBYTE \
assert(sv)
#ifndef NO_MATHOMS
@@ -3193,7 +3193,7 @@ PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp);
+PERL_CALLCONV char* Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags);
#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
assert(sv)
#ifndef NO_MATHOMS
diff --git a/sv.c b/sv.c
index abb1ed4a10..c81f23c143 100644
--- a/sv.c
+++ b/sv.c
@@ -3270,18 +3270,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;
- 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);
}
@@ -3297,15 +3298,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;
+ 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 4bf948f6d7..8f60c3f538 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,6 +1726,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))
@@ -1740,6 +1744,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))
@@ -1931,7 +1939,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)
--
2.11.0
|
From @paliv2-0004-Implement-SvPV-_or_null.patchFrom 807b85a3d7681382a37c85987c52cdb3a48d55c6 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH 4/4] Implement SvPV*_or_null*
---
sv.h | 20 ++++++++++++++++++++
1 file changed, 20 insertions(+)
diff --git a/sv.h b/sv.h
index 8f60c3f538..c5fd59b217 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,10 +1726,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1744,10 +1754,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @tonycozOn Thu, 13 Sep 2018 01:08:29 -0700, pali@cpan.org wrote:
embed.h is a generated file, modify embed.fnc and then regenerate embed.fnc with make regen. Tony |
From @paliOn Thursday 13 September 2018 18:18:57 Tony Cook via RT wrote:
Fixed. New patches are attached. |
From @paliv3-0001-Implement-sv_utf8_downgrade_nomg.patchFrom 19919d1148789e45def7c7d0fa14a43fee6e2933 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH 1/4] Implement sv_utf8_downgrade_nomg
---
embed.fnc | 3 ++-
embed.h | 2 +-
proto.h | 5 +++++
sv.c | 9 ++++++---
sv.h | 2 ++
5 files changed, 16 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 7bffdc67ea..5f47efa437 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2051,7 +2051,8 @@ 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
-ApdM |bool |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+ApdMmb |bool |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+ApdM |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
ApdM |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 8e762bc248..c82799b75b 100644
--- a/embed.h
+++ b/embed.h
@@ -850,7 +850,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/proto.h b/proto.h
index 0e6c76a3bc..e0e22edff2 100644
--- a/proto.h
+++ b/proto.h
@@ -3652,9 +3652,14 @@ 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 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 77f63183f7..abb1ed4a10 100644
--- a/sv.c
+++ b/sv.c
@@ -3600,7 +3600,7 @@ use the C<Encode> extension for that.
*/
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;
@@ -3608,7 +3608,10 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
- int mg_flags = SV_GMAGIC;
+ int mg_flags = 0;
+
+ if (flags & SV_GMAGIC)
+ mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
@@ -3618,7 +3621,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 f3392b08ec..4bf948f6d7 100644
--- a/sv.h
+++ b/sv.h
@@ -1915,6 +1915,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) \
--
2.11.0
|
From @paliv3-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom 85ef5d3ab3d1e64712c8bc384bfdc81dd5205658 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH 2/4] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 54e35f10a6..febff6e217 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv3-0003-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom 08bc280375e898e1d909e9f30c70f45b215c10c2 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH 3/4] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.fnc | 6 ++++--
embed.h | 4 ++--
proto.h | 10 ++++++++++
sv.c | 20 ++++++++++++--------
sv.h | 10 ++++++++++
5 files changed, 38 insertions(+), 12 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 5f47efa437..e35717d78d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1539,8 +1539,10 @@ Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags
pMd |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
+Apd |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
+Apd |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 c82799b75b..4844f6dbbb 100644
--- a/embed.h
+++ b/embed.h
@@ -723,8 +723,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/proto.h b/proto.h
index e0e22edff2..49a952897f 100644
--- a/proto.h
+++ b/proto.h
@@ -3183,9 +3183,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__;
@@ -3193,9 +3198,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 abb1ed4a10..c81f23c143 100644
--- a/sv.c
+++ b/sv.c
@@ -3270,18 +3270,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;
- 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);
}
@@ -3297,15 +3298,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;
+ 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 4bf948f6d7..8f60c3f538 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,6 +1726,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))
@@ -1740,6 +1744,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))
@@ -1931,7 +1939,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)
--
2.11.0
|
From @paliv3-0004-Implement-SvPV-_or_null.patchFrom 3799aa59f8e1c48411739d236201c87c937d0649 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH 4/4] Implement SvPV*_or_null*
---
sv.h | 20 ++++++++++++++++++++
1 file changed, 20 insertions(+)
diff --git a/sv.h b/sv.h
index 8f60c3f538..c5fd59b217 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,10 +1726,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1744,10 +1754,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @paliIn attachment is a new version of patches. |
From @paliv4-0001-Implement-sv_utf8_downgrade_nomg.patchFrom 4cd6d91dfb0c63abbad832dd032880151178f107 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH 1/4] Implement sv_utf8_downgrade_nomg
---
embed.fnc | 3 ++-
embed.h | 2 +-
proto.h | 5 +++--
sv.c | 11 +++++++----
sv.h | 2 ++
5 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 7bffdc6..ed1ab8a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2051,7 +2051,8 @@ 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
-ApdM |bool |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+ApdMm |bool |sv_utf8_downgrade|NN SV *const sv|const bool fail_ok
+ApdM |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
ApdM |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 8e762bc..c82799b 100644
--- a/embed.h
+++ b/embed.h
@@ -850,7 +850,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/proto.h b/proto.h
index 0e6c76a..b2a68f5 100644
--- a/proto.h
+++ b/proto.h
@@ -3652,8 +3652,9 @@ 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)
-PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok);
-#define PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE \
+/* PERL_CALLCONV bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok); */
+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 void Perl_sv_utf8_encode(pTHX_ SV *const sv);
#define PERL_ARGS_ASSERT_SV_UTF8_ENCODE \
diff --git a/sv.c b/sv.c
index 77f6318..e8c372f 100644
--- a/sv.c
+++ b/sv.c
@@ -3600,15 +3600,18 @@ use the C<Encode> extension for that.
*/
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;
+ int mg_flags = 0;
+
+ if (flags & SV_GMAGIC)
+ mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
@@ -3618,7 +3621,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 f3392b0..4bf948f 100644
--- a/sv.h
+++ b/sv.h
@@ -1915,6 +1915,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) \
--
2.11.0
|
From @paliv4-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom 4abad462f11d69b222a6ab858d25163797ea67e1 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH 2/4] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 54e35f1..febff6e 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv4-0003-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom e1589f03171ded795a69cf97b12c005db9131d11 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH 3/4] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.fnc | 6 ++++--
embed.h | 4 ++--
proto.h | 10 ++++++----
sv.c | 24 ++++++++++++++----------
sv.h | 10 ++++++++++
5 files changed, 36 insertions(+), 18 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index ed1ab8a..d37687f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1539,8 +1539,10 @@ Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags
pMd |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
+Apdm |char* |sv_2pvutf8 |NN SV *sv|NULLOK STRLEN *const lp
+Apd |char* |sv_2pvutf8_flags |NN SV *sv|NULLOK STRLEN *const lp|const U32 flags
+Apdm |char* |sv_2pvbyte |NN SV *sv|NULLOK STRLEN *const lp
+Apd |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 c82799b..4844f6d 100644
--- a/embed.h
+++ b/embed.h
@@ -723,8 +723,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/proto.h b/proto.h
index b2a68f5..8b49e25 100644
--- a/proto.h
+++ b/proto.h
@@ -3183,8 +3183,9 @@ PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp);
-#define PERL_ARGS_ASSERT_SV_2PVBYTE \
+/* PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp); */
+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)
@@ -3193,8 +3194,9 @@ PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv)
assert(sv)
#endif
-PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp);
-#define PERL_ARGS_ASSERT_SV_2PVUTF8 \
+/* PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp); */
+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)
diff --git a/sv.c b/sv.c
index e8c372f..86c39e0 100644
--- a/sv.c
+++ b/sv.c
@@ -3270,18 +3270,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);
}
@@ -3297,15 +3298,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 4bf948f..8f60c3f 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,6 +1726,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))
@@ -1740,6 +1744,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))
@@ -1931,7 +1939,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)
--
2.11.0
|
From @paliv4-0004-Implement-SvPV-_or_null.patchFrom bf8013240858c9142cb9ad23c1ce40e29940f881 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH 4/4] Implement SvPV*_or_null*
---
sv.h | 20 ++++++++++++++++++++
1 file changed, 20 insertions(+)
diff --git a/sv.h b/sv.h
index 8f60c3f..c5fd59b 100644
--- a/sv.h
+++ b/sv.h
@@ -1726,10 +1726,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1744,10 +1754,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @tonycozOn Wed, 26 Sep 2018 08:59:32 -0700, pali@cpan.org wrote:
You originally posted these as RFC, so I won't apply them right now, so some comments: a) you modify do_vecset() and do_vecget() presumably to reduce the number of magic calls they make, but you don't test for it (see t/op/bop.t for some examples.) b) your second patch actually fixes a bug with vecset() on magic scalars, for example, with the following in bop.t: my $zstr = "d"; the vecset() writes to freed memory (the extra magic calls allocate a new PV, but the code uses the old PV.)[1] c) None of your new macros/functions have documentation d) I'm not sure the _or_null macros add much. Tony [1] ================================================================= 0x60200004a530 is located 0 bytes inside of 10-byte region [0x60200004a530,0x60200004a53a) previously allocated by thread T0 here: SUMMARY: AddressSanitizer: heap-use-after-free /home/tony/dev/perl/git/perl/doop.c:974 in Perl_do_vecset |
From @paliOn Tuesday 02 October 2018 21:35:53 Tony Cook via RT wrote:
I dot not know how to write tests for these calls. If somebody else can
I'm not aware of the fact that patch fixed some memory problem :D
Where should be documentation put?
I described reason in the first email. Example: void Basically you do not need to handle undef specially, and write XS |
From @tonycozOn Wed, 03 Oct 2018 02:00:56 -0700, pali@cpan.org wrote:
bop.t has code that does similar checks for the number of magic calls done.
Where other similar code is documented. The SvPV macros in sv.h, the new downgrade where the old downgrade is documented. Tony |
From @paliIn attachment is V5 version of patches. There is updated documentation for them. |
From @paliv5-0001-Implement-sv_utf8_downgrade_nomg.patchFrom d70eebea73163b8ad76da81702eb5508cc7252a4 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH v5 1/4] Implement sv_utf8_downgrade_nomg
---
embed.fnc | 4 +++-
embed.h | 2 +-
mathoms.c | 8 ++++++++
proto.h | 6 ++++++
sv.c | 21 ++++++++++++++++++---
sv.h | 2 ++
6 files changed, 38 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 2f8dd63487..3e020bf7d8 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2045,7 +2045,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 9439f4083b..54005c4d01 100644
--- a/embed.h
+++ b/embed.h
@@ -850,7 +850,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 b8dcb8913d..da52a41604 100644
--- 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 500c5813c6..c6ad3ddc2e 100644
--- a/proto.h
+++ b/proto.h
@@ -3661,9 +3661,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 2123cf497b..2ab5f224c8 100644
--- a/sv.c
+++ b/sv.c
@@ -3648,11 +3648,23 @@ 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;
@@ -3660,7 +3672,10 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
- int mg_flags = SV_GMAGIC;
+ int mg_flags = 0;
+
+ if (flags & SV_GMAGIC)
+ mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
@@ -3670,7 +3685,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 3a648e4971..deb365ea84 100644
--- a/sv.h
+++ b/sv.h
@@ -1915,6 +1915,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) \
--
2.11.0
|
From @paliv5-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom 35002d119911774e3d5d3f7ee4a80c7742aa41fd Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH v5 2/4] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 54e35f10a6..febff6e217 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv5-0003-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom 16531de1850359b66e1bbf3afdc8fde218fbb596 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH v5 3/4] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.fnc | 6 ++++--
embed.h | 4 ++--
mathoms.c | 16 ++++++++++++++++
proto.h | 10 ++++++++++
sv.c | 24 ++++++++++++++----------
sv.h | 16 ++++++++++++++++
6 files changed, 62 insertions(+), 14 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 3e020bf7d8..e429ab065b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1538,8 +1538,10 @@ Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags
pMd |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
+Xpd |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
+Xpd |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 54005c4d01..8f3f369540 100644
--- a/embed.h
+++ b/embed.h
@@ -723,8 +723,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/mathoms.c b/mathoms.c
index da52a41604..1ba9c2367a 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 c6ad3ddc2e..2c6892bf5a 100644
--- a/proto.h
+++ b/proto.h
@@ -3192,9 +3192,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__;
@@ -3202,9 +3207,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 2ab5f224c8..fd837de54f 100644
--- a/sv.c
+++ b/sv.c
@@ -3321,18 +3321,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);
}
@@ -3348,15 +3349,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 deb365ea84..9fe5359e92 100644
--- a/sv.h
+++ b/sv.h
@@ -1596,6 +1596,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.
@@ -1605,6 +1608,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.
@@ -1726,6 +1732,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))
@@ -1740,6 +1750,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))
@@ -1931,7 +1945,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)
--
2.11.0
|
From @paliv5-0004-Implement-SvPV-_or_null.patchFrom 3aa1c8d06aa8c762967d499659c3ba3524fd4720 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH v5 4/4] Implement SvPV*_or_null*
---
sv.h | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
diff --git a/sv.h b/sv.h
index 9fe5359e92..41cb597b1f 100644
--- a/sv.h
+++ b/sv.h
@@ -1599,6 +1599,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVutf8>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVutf8_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVutf8_or_null>, 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.
@@ -1611,6 +1617,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVbyte>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVbyte_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVbyte_or_null>, 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.
@@ -1732,10 +1744,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1750,10 +1772,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @paliOn Thursday 28 February 2019 15:57:17 pali@cpan.org wrote:
Tony, can you look at new patch version? |
From @tonycozOn Tue, 19 Mar 2019 01:55:18 -0700, pali@cpan.org wrote:
make test fails. There still aren't any vec() tests (see the attached.) There's no tests for the new APIs (which can go in ext/XS-APItest/) Tony |
From @tonycoz0001-test-for-desired-magic-fetches-stores-for-vec.patchFrom 6477fcd4c8ae0e0ad01dd73006587cf6f14f9ebb Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 20 Mar 2019 10:53:17 +1100
Subject: test for desired magic fetches/stores for vec()
for #132782
---
t/op/bop.t | 43 ++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 42 insertions(+), 1 deletion(-)
diff --git a/t/op/bop.t b/t/op/bop.t
index 411d253a7b..a741cfbbaf 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -18,7 +18,7 @@ BEGIN {
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 504;
+plan tests => 514;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -262,6 +262,47 @@ is(~~$y, "c");
is(fetches($y), 1);
is(stores($y), 0);
+my $g;
+# Note: if the vec() reads are part of the is() calls it's treated as
+# in lvalue context, so we save it separately
+$g = vec($x, 0, 1);
+is($g, (ord("a") & 0x01), "check vec value");
+{
+local $TODO = "fetches for vec read broken";
+is(fetches($x), 1, "fetches for vec read");
+}
+is(stores($x), 0, "stores for vec read");
+# similarly here, and code like:
+# $g = (vec($x, 0, 1) = 0)
+# results in an extra fetch, since the inner assignment returns the LV
+vec($x, 0, 1) = 0;
+# one fetch in vec() another when the LV is assigned to
+{
+local $TODO = "fetches for vec read broken";
+is(fetches($x), 2, "fetches for vec write");
+}
+is(stores($x), 1, "stores for vec write");
+
+{
+ my $a = "a";
+ utf8::upgrade($a);
+ tie $x, "main", $a;
+ $g = vec($x, 0, 1);
+ is($g, (ord("a") & 0x01), "check vec value (utf8)");
+ {
+ local $TODO = "fetches for vec read broken";
+ is(fetches($x), 1, "fetches for vec read (utf8)");
+ }
+ is(stores($x), 0, "stores for vec read (utf8)");
+ vec($x, 0, 1) = 0;
+ {
+ local $TODO = "fetches for vec read broken";
+ # one fetch in vec() another when the LV is assigned to
+ is(fetches($x), 2, "fetches for vec write (utf8)");
+ }
+ is(stores($x), 1, "stores for vec write (utf8)");
+}
+
$a = "\0\x{100}"; chop($a);
ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there
$a = ~$a;
--
2.11.0
|
From @tonycozOn Tue, 19 Mar 2019 20:49:46 -0700, tonyc wrote:
Also: - int mg_flags = SV_GMAGIC; Can just be: int mg_flags = flags & SV_GMAGIC; but should probably be: U32 mg_flags = flags & SV_GMAGIC; Tony |
From @paliOn Tuesday 19 March 2019 20:59:22 Tony Cook via RT wrote:
Fixed.
I included that patch into v6 version.
Changed. New version v6 is in attachment. Now make test passes. There are some problems with porting/pod_rules.t |
From @paliv6-0001-Implement-sv_utf8_downgrade_nomg.patchFrom b053620962bfd8b3a5bef073d530fd9fed5e8066 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH 1/5] Implement sv_utf8_downgrade_nomg
---
embed.fnc | 4 +++-
embed.h | 2 +-
mathoms.c | 8 ++++++++
proto.h | 6 ++++++
sv.c | 20 ++++++++++++++++----
sv.h | 2 ++
6 files changed, 36 insertions(+), 6 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index e2ca5c5808..b5a4c41451 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2045,7 +2045,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 94acff2444..eb56be425e 100644
--- a/embed.h
+++ b/embed.h
@@ -850,7 +850,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 b8dcb8913d..da52a41604 100644
--- 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 b9662c6a33..a7f0ff3395 100644
--- a/proto.h
+++ b/proto.h
@@ -3666,9 +3666,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 b6d9123971..565a46aac1 100644
--- a/sv.c
+++ b/sv.c
@@ -3648,19 +3648,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);
@@ -3670,7 +3682,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 3a648e4971..deb365ea84 100644
--- a/sv.h
+++ b/sv.h
@@ -1915,6 +1915,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) \
--
2.11.0
|
From @paliv6-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom b7ea3a69ae731dfc2ea96a04699630285b259f33 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH 2/5] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 54e35f10a6..febff6e217 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -934,10 +934,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv6-0003-test-for-desired-magic-fetches-stores-for-vec.patchFrom 30be11b11c45dd6d01564b6e375d5b406dd4d0af Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 20 Mar 2019 10:53:17 +1100
Subject: [PATCH 3/5] test for desired magic fetches/stores for vec()
for #132782
---
t/op/bop.t | 43 ++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 42 insertions(+), 1 deletion(-)
diff --git a/t/op/bop.t b/t/op/bop.t
index 411d253a7b..a741cfbbaf 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -18,7 +18,7 @@ BEGIN {
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 504;
+plan tests => 514;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -262,6 +262,47 @@ is(~~$y, "c");
is(fetches($y), 1);
is(stores($y), 0);
+my $g;
+# Note: if the vec() reads are part of the is() calls it's treated as
+# in lvalue context, so we save it separately
+$g = vec($x, 0, 1);
+is($g, (ord("a") & 0x01), "check vec value");
+{
+local $TODO = "fetches for vec read broken";
+is(fetches($x), 1, "fetches for vec read");
+}
+is(stores($x), 0, "stores for vec read");
+# similarly here, and code like:
+# $g = (vec($x, 0, 1) = 0)
+# results in an extra fetch, since the inner assignment returns the LV
+vec($x, 0, 1) = 0;
+# one fetch in vec() another when the LV is assigned to
+{
+local $TODO = "fetches for vec read broken";
+is(fetches($x), 2, "fetches for vec write");
+}
+is(stores($x), 1, "stores for vec write");
+
+{
+ my $a = "a";
+ utf8::upgrade($a);
+ tie $x, "main", $a;
+ $g = vec($x, 0, 1);
+ is($g, (ord("a") & 0x01), "check vec value (utf8)");
+ {
+ local $TODO = "fetches for vec read broken";
+ is(fetches($x), 1, "fetches for vec read (utf8)");
+ }
+ is(stores($x), 0, "stores for vec read (utf8)");
+ vec($x, 0, 1) = 0;
+ {
+ local $TODO = "fetches for vec read broken";
+ # one fetch in vec() another when the LV is assigned to
+ is(fetches($x), 2, "fetches for vec write (utf8)");
+ }
+ is(stores($x), 1, "stores for vec write (utf8)");
+}
+
$a = "\0\x{100}"; chop($a);
ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there
$a = ~$a;
--
2.11.0
|
From @paliv6-0004-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom 6083c520f2be25a874867a1ab791cd6d63e4317e Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH 4/5] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.fnc | 6 ++++--
embed.h | 4 ++--
mathoms.c | 16 ++++++++++++++++
proto.h | 10 ++++++++++
sv.c | 24 ++++++++++++++----------
sv.h | 16 ++++++++++++++++
6 files changed, 62 insertions(+), 14 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b5a4c41451..03dafca381 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1538,8 +1538,10 @@ Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags
pMd |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 eb56be425e..fe562286bb 100644
--- a/embed.h
+++ b/embed.h
@@ -723,8 +723,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/mathoms.c b/mathoms.c
index da52a41604..1ba9c2367a 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 a7f0ff3395..f67ffc47c8 100644
--- a/proto.h
+++ b/proto.h
@@ -3197,9 +3197,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__;
@@ -3207,9 +3212,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 565a46aac1..02e74b5372 100644
--- a/sv.c
+++ b/sv.c
@@ -3321,18 +3321,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);
}
@@ -3348,15 +3349,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 deb365ea84..9fe5359e92 100644
--- a/sv.h
+++ b/sv.h
@@ -1596,6 +1596,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.
@@ -1605,6 +1608,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.
@@ -1726,6 +1732,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))
@@ -1740,6 +1750,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))
@@ -1931,7 +1945,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)
--
2.11.0
|
From @paliv6-0005-Implement-SvPV-_or_null.patchFrom 560dfa83bee3e9efde3a13bc5f9b831ec43b1ad9 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH 5/5] Implement SvPV*_or_null*
---
sv.h | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
diff --git a/sv.h b/sv.h
index 9fe5359e92..41cb597b1f 100644
--- a/sv.h
+++ b/sv.h
@@ -1599,6 +1599,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVutf8>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVutf8_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVutf8_or_null>, 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.
@@ -1611,6 +1617,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVbyte>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVbyte_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVbyte_or_null>, 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.
@@ -1732,10 +1744,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1750,10 +1772,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @paliOn Thursday 28 March 2019 13:41:30 pali@cpan.org wrote:
Tony, can you review V6 patches? |
From @paliOn Tuesday 21 May 2019 10:17:47 Tony Cook wrote:
I removed TODO marks in this test.
I added XS-API tests for SvPVutf8_nomg and SvPVbyte_nomg. Please look at updated V7 patches. |
From @paliv7-0001-Implement-sv_utf8_downgrade_nomg.patchFrom c77f48b199535c89bd57ad056c7df362266e6a1f Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:40:47 +0100
Subject: [PATCH 1/5] Implement sv_utf8_downgrade_nomg
---
embed.fnc | 4 +++-
embed.h | 2 +-
mathoms.c | 8 ++++++++
proto.h | 6 ++++++
sv.c | 20 ++++++++++++++++----
sv.h | 2 ++
6 files changed, 36 insertions(+), 6 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index aa23c1a6c9..07287892f3 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2111,7 +2111,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 78659236b4..5f7cb5f58f 100644
--- 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 e2dc11c142..6450291317 100644
--- 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 5eaec442b2..ac500a581e 100644
--- 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 4315fe9b64..f6665bc030 100644
--- 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 24c728dcd2..53aea18aeb 100644
--- 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) \
--
2.11.0
|
From @paliv7-0002-Fix-do_vecget-and-do_vecset-to-process-GET-magic-onl.patchFrom 79605516735866f2c42e6a2e7b5ca979a610842f Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:19 +0100
Subject: [PATCH 2/5] Fix do_vecget and do_vecset to process GET magic only
once
---
doop.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/doop.c b/doop.c
index 00edfcc2e7..49f71e681d 100644
--- a/doop.c
+++ b/doop.c
@@ -758,7 +758,7 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
Perl_croak(aTHX_ "Illegal number of bits in vec");
if (SvUTF8(sv)) {
- if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) {
+ if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
/* PVX may have changed */
s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
}
@@ -931,10 +931,10 @@ Perl_do_vecset(pTHX_ SV *sv)
SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
if (SvUTF8(targ)) {
/* This is handled by the SvPOK_only below...
- if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
+ if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
SvUTF8_off(targ);
*/
- (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
+ (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
}
(void)SvPOK_only(targ);
--
2.11.0
|
From @paliv7-0003-test-for-desired-magic-fetches-stores-for-vec.patchFrom 3a1e7b5df42099af3eef92a2c51423de3552e749 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 20 Mar 2019 10:53:17 +1100
Subject: [PATCH 3/5] test for desired magic fetches/stores for vec()
for #132782
---
t/op/bop.t | 31 ++++++++++++++++++++++++++++++-
1 file changed, 30 insertions(+), 1 deletion(-)
diff --git a/t/op/bop.t b/t/op/bop.t
index 666dfb8114..efc6172fc1 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -18,7 +18,7 @@ BEGIN {
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 491;
+plan tests => 501;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -262,6 +262,35 @@ is(~~$y, "c");
is(fetches($y), 1);
is(stores($y), 0);
+my $g;
+# Note: if the vec() reads are part of the is() calls it's treated as
+# in lvalue context, so we save it separately
+$g = vec($x, 0, 1);
+is($g, (ord("a") & 0x01), "check vec value");
+is(fetches($x), 1, "fetches for vec read");
+is(stores($x), 0, "stores for vec read");
+# similarly here, and code like:
+# $g = (vec($x, 0, 1) = 0)
+# results in an extra fetch, since the inner assignment returns the LV
+vec($x, 0, 1) = 0;
+# one fetch in vec() another when the LV is assigned to
+is(fetches($x), 2, "fetches for vec write");
+is(stores($x), 1, "stores for vec write");
+
+{
+ my $a = "a";
+ utf8::upgrade($a);
+ tie $x, "main", $a;
+ $g = vec($x, 0, 1);
+ is($g, (ord("a") & 0x01), "check vec value (utf8)");
+ is(fetches($x), 1, "fetches for vec read (utf8)");
+ is(stores($x), 0, "stores for vec read (utf8)");
+ vec($x, 0, 1) = 0;
+ # one fetch in vec() another when the LV is assigned to
+ is(fetches($x), 2, "fetches for vec write (utf8)");
+ is(stores($x), 1, "stores for vec write (utf8)");
+}
+
$a = "\0\x{100}"; chop($a);
ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there
$a = ~$a;
--
2.11.0
|
From @paliv7-0004-Implement-SvPVutf8_nomg-and-SvPVbyte_nomg.patchFrom f496f6b5cc720e9bfaa27910cb18fef3bf2c33a5 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 13:41:46 +0100
Subject: [PATCH 4/5] Implement SvPVutf8_nomg and SvPVbyte_nomg
---
embed.fnc | 6 ++++--
embed.h | 4 ++--
ext/XS-APItest/APItest.xs | 14 ++++++++++++++
ext/XS-APItest/t/svpv.t | 47 ++++++++++++++++++++++++++++++++++++++++++++++-
mathoms.c | 16 ++++++++++++++++
proto.h | 10 ++++++++++
sv.c | 24 ++++++++++++++----------
sv.h | 16 ++++++++++++++++
8 files changed, 122 insertions(+), 15 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 07287892f3..eaf459bcf9 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1603,8 +1603,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 ac500a581e..0f42160063 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 f6665bc030..ba7a566aeb 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)
--
2.11.0
|
From @paliv7-0005-Implement-SvPV-_or_null.patchFrom 7d2308925b36601e2817a2f6f5ee77f405a95e5f Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sat, 10 Feb 2018 15:10:04 +0100
Subject: [PATCH 5/5] Implement SvPV*_or_null*
---
sv.h | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
diff --git a/sv.h b/sv.h
index 1f24f773a0..56a7cc50dc 100644
--- a/sv.h
+++ b/sv.h
@@ -1625,6 +1625,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVutf8>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVutf8_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVutf8_or_null>, 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.
@@ -1637,6 +1643,12 @@ 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_or_null|SV* sv|STRLEN len
+Like C<SvPVbyte>, but when C<sv> is undef then returns C<NULL>.
+
+=for apidoc Am|char*|SvPVbyte_or_null_nomg|SV* sv|STRLEN len
+Like C<SvPVbyte_or_null>, 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.
@@ -1758,10 +1770,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
+#define SvPVutf8_or_null(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_nomg(sv, lp) \
(SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8_flags(sv, &lp, 0))
+#define SvPVutf8_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvutf8_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVutf8_force(sv, lp) \
(SvPOK_utf8_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
@@ -1776,10 +1798,20 @@ Like C<sv_catsv> but doesn't process magic.
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+#define SvPVbyte_or_null(sv, lp) \
+ (SvPOK_byte_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : (SvGETMAGIC(sv), SvOK(sv)) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_nomg(sv, lp) \
(SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte_flags(sv, &lp, 0))
+#define SvPVbyte_or_null_nomg(sv, lp) \
+ (SvPOK_utf8_nog(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : SvOK(sv) \
+ ? sv_2pvbyte_flags(sv, &lp, 0) : ((lp = 0), NULL))
+
#define SvPVbyte_force(sv, lp) \
(SvPOK_byte_pure_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
--
2.11.0
|
From @paliOn Monday 22 July 2019 15:53:30 pali@cpan.org wrote:
Hi Tony! It is now OK? Or is something more needed for these patches? |
From @paliOn Tuesday 06 August 2019 11:03:47 pali@cpan.org wrote:
Tony: ping |
From @tonycozOn Fri, 30 Aug 2019 05:00:52 -0700, pali@cpan.org wrote:
Thanks, applied as 423ce62 through 3e13e8f. Sorry about the lack of follow-up, I forgot to bookmark this ticket and lost track of it otherwise. Tony |
|
@tonycoz - Status changed from 'open' to 'pending release' |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Migrated from rt.perl.org#132782 (status was 'pending release')
Searchable as RT132782$
The text was updated successfully, but these errors were encountered: