In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/e99ccafab27dc0d084a8c16ed5a07fe8f4cc87ce?hp=7ea7c4bb61d23965a7ad7041fe9c58b5075aac85>
- Log ----------------------------------------------------------------- commit e99ccafab27dc0d084a8c16ed5a07fe8f4cc87ce Merge: 7ea7c4bb61 10032e64f3 Author: Tony Cook <[email protected]> Date: Mon Sep 2 11:35:47 2019 +1000 More SvPV* macros commit 10032e64f3fae241388253fee5a76a270864e4e0 Author: Tony Cook <[email protected]> Date: Mon Sep 2 11:28:16 2019 +1000 bump $XS::APItest::VERSION commit 3e13e8f6968d020943ce324057a81959fc9c5631 Author: Pali <[email protected]> Date: Sat Feb 10 15:10:04 2018 +0100 Implement SvPV*_or_null* commit 757fc3292f5193d0ad3394e62e13f96058ccaca4 Author: Pali <[email protected]> Date: Sat Feb 10 13:41:46 2018 +0100 Implement SvPVutf8_nomg and SvPVbyte_nomg commit ce40079591b504f12c3ec817875327870e1a0630 Author: Tony Cook <[email protected]> Date: Wed Mar 20 10:53:17 2019 +1100 test for desired magic fetches/stores for vec() for #132782 commit 27c41eac9877077f4ce636c417f5e3904a95754b Author: Pali <[email protected]> Date: Sat Feb 10 13:41:19 2018 +0100 Fix do_vecget and do_vecset to process GET magic only once commit 423ce6234bb755185e783187da2b1fc06560ce8b Author: Pali <[email protected]> Date: Sat Feb 10 13:40:47 2018 +0100 Implement sv_utf8_downgrade_nomg ----------------------------------------------------------------------- Summary of changes: doop.c | 6 +++--- embed.fnc | 10 +++++++--- embed.h | 6 +++--- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 14 +++++++++++++ ext/XS-APItest/t/svpv.t | 47 +++++++++++++++++++++++++++++++++++++++++++- mathoms.c | 24 +++++++++++++++++++++++ proto.h | 16 +++++++++++++++ sv.c | 44 ++++++++++++++++++++++++++++------------- sv.h | 50 +++++++++++++++++++++++++++++++++++++++++++++++ t/op/bop.t | 31 ++++++++++++++++++++++++++++- 11 files changed, 224 insertions(+), 26 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); diff --git a/embed.fnc b/embed.fnc index c3732052c7..0c21485b3f 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1606,8 +1606,10 @@ Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags pxd |SV* |sv_2num |NN SV *const sv Apmb |char* |sv_2pv |NN SV *sv|NULLOK STRLEN *lp Apd |char* |sv_2pv_flags |NN SV *const sv|NULLOK STRLEN *const lp|const I32 flags -Apd |char* |sv_2pvutf8 |NN SV *sv|NULLOK STRLEN *const lp -Apd |char* |sv_2pvbyte |NN SV *sv|NULLOK STRLEN *const lp +Apdmb |char* |sv_2pvutf8 |NN SV *sv|NULLOK STRLEN *const lp +Ap |char* |sv_2pvutf8_flags |NN SV *sv|NULLOK STRLEN *const lp|const U32 flags +Apdmb |char* |sv_2pvbyte |NN SV *sv|NULLOK STRLEN *const lp +Ap |char* |sv_2pvbyte_flags |NN SV *sv|NULLOK STRLEN *const lp|const U32 flags Abp |char* |sv_pvn_nomg |NN SV* sv|NULLOK STRLEN* lp Apmb |UV |sv_2uv |NN SV *sv Apd |UV |sv_2uv_flags |NN SV *const sv|const I32 flags @@ -2114,7 +2116,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..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) @@ -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/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 3467e5fdda..49ad7c5248 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.02'; +our $VERSION = '1.03'; require XSLoader; 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 @@ -4218,6 +4218,13 @@ CODE: OUTPUT: RETVAL +char * +SvPVbyte_nomg(SV *sv) +CODE: + RETVAL = SvPVbyte_nomg(sv, PL_na); +OUTPUT: + RETVAL + char * SvPVutf8(SV *sv) CODE: @@ -4225,6 +4232,13 @@ CODE: 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 e2dc11c142..65bf267943 100644 --- a/mathoms.c +++ b/mathoms.c @@ -1761,6 +1761,30 @@ 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); +} + +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 29a1e0cb6c..63814ff1b1 100644 --- a/proto.h +++ b/proto.h @@ -3232,9 +3232,14 @@ PERL_CALLCONV char* Perl_sv_2pv_nolen(pTHX_ SV* sv) assert(sv) #endif +#ifndef NO_MATHOMS PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp); #define PERL_ARGS_ASSERT_SV_2PVBYTE \ assert(sv) +#endif +PERL_CALLCONV char* Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags); +#define PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS \ + assert(sv) #ifndef NO_MATHOMS PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv) __attribute__warn_unused_result__; @@ -3242,9 +3247,14 @@ PERL_CALLCONV char* Perl_sv_2pvbyte_nolen(pTHX_ SV* sv) assert(sv) #endif +#ifndef NO_MATHOMS PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp); #define PERL_ARGS_ASSERT_SV_2PVUTF8 \ assert(sv) +#endif +PERL_CALLCONV char* Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags); +#define PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS \ + assert(sv) #ifndef NO_MATHOMS PERL_CALLCONV char* Perl_sv_2pvutf8_nolen(pTHX_ SV* sv) __attribute__warn_unused_result__; @@ -3701,9 +3711,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 df0b601650..e591f7c60c 100644 --- a/sv.c +++ b/sv.c @@ -3322,18 +3322,19 @@ Usually accessed via the C<SvPVbyte> macro. */ char * -Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) +Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) { - PERL_ARGS_ASSERT_SV_2PVBYTE; + PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS; - SvGETMAGIC(sv); + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) || isGV_with_GP(sv) || SvROK(sv)) { SV *sv2 = sv_newmortal(); sv_copypv_nomg(sv2,sv); sv = sv2; } - sv_utf8_downgrade(sv,0); + sv_utf8_downgrade_nomg(sv,0); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3349,15 +3350,18 @@ Usually accessed via the C<SvPVutf8> macro. */ char * -Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) +Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) { - PERL_ARGS_ASSERT_SV_2PVUTF8; + PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS; + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) - || isGV_with_GP(sv) || SvROK(sv)) - sv = sv_mortalcopy(sv); - else - SvGETMAGIC(sv); + || isGV_with_GP(sv) || SvROK(sv)) { + SV *sv2 = sv_newmortal(); + sv_copypv_nomg(sv2,sv); + sv = sv2; + } sv_utf8_upgrade_nomg(sv); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3649,19 +3653,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 +3687,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..56a7cc50dc 100644 --- a/sv.h +++ b/sv.h @@ -1622,6 +1622,15 @@ 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_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. @@ -1631,6 +1640,15 @@ 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_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. @@ -1752,6 +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)) @@ -1766,6 +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)) @@ -1941,6 +1987,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) \ @@ -1955,7 +2003,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) 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; -- Perl5 Master Repository
