From 93e5ba4cd5a975ef6af05254b1e81581cf18f953 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Sat, 7 Aug 2021 14:46:48 +0100 Subject: [PATCH 1/9] Define a third kind of COW state; STATIC Previously, when IsCOW flag was set there were two cases: SvLEN()==0: PV is really a shared HEK SvLEN()!=0: PV is a COW structure with 1..256 refcount stored in its extra final byte This change adds a third state: SvLEN()==0 && SvFLAGS() & SVppv_STATIC: PV is a shared static const pointer and must not be modified sv_setsv_flags() and sv_setsv_cow() will preserve this state sv_uncow() will copy it out to a regular string buffer sv_dup() will preserve the static pointer into cloned threads --- sv.c | 41 ++++++++++++++++++++++++++++++----------- sv.h | 11 +++++++---- 2 files changed, 37 insertions(+), 15 deletions(-) diff --git a/sv.c b/sv.c index 286abc545e00..74e9bac1b6ce 100644 --- a/sv.c +++ b/sv.c @@ -4687,6 +4687,15 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) SvCUR_set(ssv, 0); SvTEMP_off(ssv); } + /* We must check for SvIsCOW_static() even without + * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL() + */ + else if (SvIsCOW_static(ssv)) { + SvPV_set(dsv, SvPVX(ssv)); + SvLEN_set(dsv, 0); + SvCUR_set(dsv, cur); + SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC); + } else if (flags & SV_COW_SHARED_HASH_KEYS && #ifdef PERL_COPY_ON_WRITE @@ -4873,6 +4882,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) STRLEN cur = SvCUR(ssv); STRLEN len = SvLEN(ssv); char *new_pv; + U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE) const bool already = cBOOL(SvIsCOW(ssv)); #endif @@ -4901,14 +4911,19 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) assert (SvPOKp(ssv)); if (SvIsCOW(ssv)) { - - if (SvLEN(ssv) == 0) { + if (SvIsCOW_shared_hash(ssv)) { /* source is a COW shared hash key. */ DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))); goto common_exit; } + else if (SvIsCOW_static(ssv)) { + /* source is static constant; preserve this */ + new_pv = SvPVX(ssv); + new_flags |= SVppv_STATIC; + goto common_exit; + } assert(SvCUR(ssv)+1 < SvLEN(ssv)); assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX); } else { @@ -4928,7 +4943,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) common_exit: SvPV_set(dsv, new_pv); - SvFLAGS(dsv) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); + SvFLAGS(dsv) = new_flags; if (SvUTF8(ssv)) SvUTF8_on(dsv); SvLEN_set(dsv, len); @@ -5220,6 +5235,7 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); + const bool was_shared_hek = SvIsCOW_shared_hash(sv); #ifdef DEBUGGING if (DEBUG_C_TEST) { @@ -5264,7 +5280,7 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - if (! len) { + if (was_shared_hek) { unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } #ifdef DEBUGGING @@ -6836,17 +6852,20 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_dump(sv); } #endif - if (SvLEN(sv)) { + if (SvIsCOW_static(sv)) { + SvLEN_set(sv, 0); + } + else if (SvIsCOW_shared_hash(sv)) { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + else { if (CowREFCNT(sv)) { sv_buf_to_rw(sv); CowREFCNT(sv)--; sv_buf_to_ro(sv); SvLEN_set(sv, 0); } - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); } - } if (SvLEN(sv)) { Safefree(SvPVX_mutable(sv)); @@ -14100,7 +14119,7 @@ Perl_rvpv_dup(pTHX_ SV *const dsv, const SV *const ssv, CLONE_PARAMS *const para if (isGV_with_GP(ssv)) { /* Don't need to do anything here. */ } - else if ((SvIsCOW(ssv))) { + else if ((SvIsCOW_shared_hash(ssv))) { /* A "shared" PV - clone it as "shared" PV */ SvPV_set(dsv, HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)), @@ -16027,13 +16046,13 @@ Perl_init_constants(pTHX) SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY|SVf_PROTECT |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_POK|SVf_POK|SVf_IsCOW|SVppv_STATIC; SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY|SVf_PROTECT |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_POK|SVf_POK|SVf_IsCOW|SVppv_STATIC; SvANY(&PL_sv_zero) = new_XPVNV(); SvREFCNT(&PL_sv_zero) = SvREFCNT_IMMORTAL; diff --git a/sv.h b/sv.h index 17d376cb161f..334176abbd62 100644 --- a/sv.h +++ b/sv.h @@ -462,6 +462,8 @@ perform the upgrade if necessary. See C>. /* Some private flags. */ +/* scalar SVs with SVp_POK */ +#define SVppv_STATIC 0x40000000 /* PV is pointer to static const; must be set with SVf_IsCOW */ /* PVAV */ #define SVpav_REAL 0x40000000 /* free old entries */ /* PVHV */ @@ -2008,10 +2010,11 @@ scalar. ) \ ) -#define SvIsCOW(sv) (SvFLAGS(sv) & SVf_IsCOW) -#define SvIsCOW_on(sv) (SvFLAGS(sv) |= SVf_IsCOW) -#define SvIsCOW_off(sv) (SvFLAGS(sv) &= ~SVf_IsCOW) -#define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0) +#define SvIsCOW(sv) (SvFLAGS(sv) & SVf_IsCOW) +#define SvIsCOW_on(sv) (SvFLAGS(sv) |= SVf_IsCOW) +#define SvIsCOW_off(sv) (SvFLAGS(sv) &= ~(SVf_IsCOW|SVppv_STATIC)) +#define SvIsCOW_shared_hash(sv) ((SvFLAGS(sv) & (SVf_IsCOW|SVppv_STATIC)) == (SVf_IsCOW) && SvLEN(sv) == 0) +#define SvIsCOW_static(sv) ((SvFLAGS(sv) & (SVf_IsCOW|SVppv_STATIC)) == (SVf_IsCOW|SVppv_STATIC)) #define SvSHARED_HEK_FROM_PV(pvx) \ ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key))) From 676b7d437aa132a61a72c90abe299896bc4550eb Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Mon, 9 Aug 2021 23:54:14 +0100 Subject: [PATCH 2/9] Add a unit test that checks we didn't break booleans with the new COW static const behaviour --- MANIFEST | 1 + t/op/bool.t | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+) create mode 100644 t/op/bool.t diff --git a/MANIFEST b/MANIFEST index 8aa617e36b9c..b9a42c0ad124 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5830,6 +5830,7 @@ t/op/auto.t See if autoincrement et all work t/op/avhv.t See if pseudo-hashes work t/op/bless.t See if bless works t/op/blocks.t See if BEGIN and friends work +t/op/bool.t Check misc details of boolean values t/op/bop.t See if bitops work t/op/caller.pl Tests shared between caller.t and XS op.t t/op/caller.t See if caller() works diff --git a/t/op/bool.t b/t/op/bool.t new file mode 100644 index 000000000000..21f6d3b7d544 --- /dev/null +++ b/t/op/bool.t @@ -0,0 +1,37 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); +} + +use strict; +use warnings; + +my $truevar = (5 == 5); +my $falsevar = (5 == 6); + +cmp_ok($truevar, '==', 1); +cmp_ok($truevar, 'eq', "1"); + +cmp_ok($falsevar, '==', 0); +cmp_ok($falsevar, 'eq', ""); + +{ + # Check that boolean COW string buffer is safe to copy into new SVs and + # doesn't get corrupted by inplace mutations + my $x = $truevar; + $x =~ s/1/t/; + + cmp_ok($x, 'eq', "t"); + cmp_ok($truevar, 'eq', "1"); + + my $y = $truevar; + substr($y, 0, 1, "T"); + + cmp_ok($y, 'eq', "T"); + cmp_ok($truevar, 'eq', "1"); +} + +done_testing(); From 69908c6ec5b09befd6c8bce2bf55babd4503a340 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Sat, 7 Aug 2021 14:48:32 +0100 Subject: [PATCH 3/9] Add SvIsBOOL() macro to test for SVs being boolean-intent These are identified as being static shared COW strings whose string buffer points directly at PL_Yes / PL_No --- sv.h | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/sv.h b/sv.h index 334176abbd62..e1853df3b13e 100644 --- a/sv.h +++ b/sv.h @@ -1051,6 +1051,19 @@ Remove any string offset. #define SvPOK_byte_pure_nogthink(sv) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_IOK|SVf_NOK|SVf_ROK|SVpgv_GP|SVf_THINKFIRST|SVs_GMG)) == SVf_POK) +/* +=for apidoc Am|BOOL|SvIsBOOL|SV* sv + +Returns true if the SV is one of the special boolean constants (PL_sv_yes or +PL_sv_no), or is a regular SV whose last assignment stored a copy of one. + +=cut +*/ + +#define SvIsBOOL(sv) \ + (SvIOK(sv) && SvPOK(sv) && SvIsCOW_static(sv) && \ + (SvPVX(sv) == PL_Yes || SvPVX(sv) == PL_No)) + /* =for apidoc Am|U32|SvGAMAGIC|SV* sv From c6b2b52ae445148aac9cba762554a0ef132e3b1a Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Sat, 7 Aug 2021 15:11:40 +0100 Subject: [PATCH 4/9] Add a Scalar::Util::isbool() Remember to SvGETMAGIC() before testing SvIsBOOL() (thanks @tonycoz) --- MANIFEST | 1 + cpan/Scalar-List-Utils/ListUtil.xs | 16 ++++++ cpan/Scalar-List-Utils/lib/List/Util.pm | 2 +- cpan/Scalar-List-Utils/lib/List/Util/XS.pm | 2 +- cpan/Scalar-List-Utils/lib/Scalar/Util.pm | 14 ++++- cpan/Scalar-List-Utils/lib/Sub/Util.pm | 2 +- cpan/Scalar-List-Utils/t/boolean.t | 64 ++++++++++++++++++++++ 7 files changed, 97 insertions(+), 4 deletions(-) create mode 100644 cpan/Scalar-List-Utils/t/boolean.t diff --git a/MANIFEST b/MANIFEST index b9a42c0ad124..6a2740d9e0f8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1977,6 +1977,7 @@ cpan/Scalar-List-Utils/multicall.h Util extension cpan/Scalar-List-Utils/t/00version.t Scalar::Util cpan/Scalar-List-Utils/t/any-all.t List::Util cpan/Scalar-List-Utils/t/blessed.t Scalar::Util +cpan/Scalar-List-Utils/t/boolean.t Scalar::Util cpan/Scalar-List-Utils/t/dualvar.t Scalar::Util cpan/Scalar-List-Utils/t/exotic_names.t cpan/Scalar-List-Utils/t/first.t List::Util diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs index 2ce9085569ff..0c1385b60285 100644 --- a/cpan/Scalar-List-Utils/ListUtil.xs +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -1665,6 +1665,19 @@ PPCODE: MODULE=List::Util PACKAGE=Scalar::Util +void +isbool(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvIsBOOL + SvGETMAGIC(sv); + ST(0) = boolSV(SvIsBOOL(sv)); + XSRETURN(1); +#else + croak("stable boolean values are not implemented in this release of perl"); +#endif + void dualvar(num,str) SV *num @@ -2119,6 +2132,9 @@ BOOT: #ifndef SvVOK av_push(varav, newSVpv("isvstring",9)); #endif +#ifndef SvIsBOOL + av_push(varav, newSVpv("isbool",6)); +#endif #ifdef REAL_MULTICALL sv_setsv(rmcsv, &PL_sv_yes); #else diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm index dad5357f4329..71f36f195608 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -16,7 +16,7 @@ our @EXPORT_OK = qw( sample shuffle uniq uniqint uniqnum uniqstr zip zip_longest zip_shortest mesh mesh_longest mesh_shortest head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst ); -our $VERSION = "1.56"; +our $VERSION = "1.56_001"; our $XS_VERSION = $VERSION; $VERSION =~ tr/_//d; diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index 70d33131cc6f..77cb68fc97e9 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -3,7 +3,7 @@ use strict; use warnings; use List::Util; -our $VERSION = "1.56"; # FIXUP +our $VERSION = "1.56_001"; # FIXUP $VERSION =~ tr/_//d; # FIXUP 1; diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index de3e892298a9..6bf01d3f98d6 100644 --- a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -14,10 +14,12 @@ our @ISA = qw(Exporter); our @EXPORT_OK = qw( blessed refaddr reftype weaken unweaken isweak + isbool + dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted ); -our $VERSION = "1.56"; +our $VERSION = "1.56_001"; $VERSION =~ tr/_//d; require List::Util; # List::Util loads the XS @@ -217,6 +219,16 @@ B: Copying a weak reference creates a normal, strong, reference. =head1 OTHER FUNCTIONS +=head2 isbool + + my $bool = isbool( $var ); + +I + +Returns true if the given variable is boolean in nature - that is, it is the +result of a boolean operator (such as C, C, or a numerical or +string comparison), or is a variable that is copied from one. + =head2 dualvar my $var = dualvar( $num, $string ); diff --git a/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/cpan/Scalar-List-Utils/lib/Sub/Util.pm index 1eee0ded4163..8b25af75445f 100644 --- a/cpan/Scalar-List-Utils/lib/Sub/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Sub/Util.pm @@ -15,7 +15,7 @@ our @EXPORT_OK = qw( subname set_subname ); -our $VERSION = "1.56"; +our $VERSION = "1.56_001"; $VERSION =~ tr/_//d; require List::Util; # as it has the XS diff --git a/cpan/Scalar-List-Utils/t/boolean.t b/cpan/Scalar-List-Utils/t/boolean.t new file mode 100644 index 000000000000..691734ea8e29 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/boolean.t @@ -0,0 +1,64 @@ +#!./perl + +use strict; +use warnings; + +use Scalar::Util (); +use Test::More (grep { /isbool/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'isbool requires XS version') + : (tests => 15); + +Scalar::Util->import("isbool"); + +# basic constants +{ + ok(isbool(!!0), 'false is boolean'); + ok(isbool(!!1), 'true is boolean'); + + ok(!isbool(0), '0 is not boolean'); + ok(!isbool(1), '1 is not boolean'); + ok(!isbool(""), '"" is not boolean'); +} + +# variables +{ + my $falsevar = !!0; + my $truevar = !!1; + + ok(isbool($falsevar), 'false var is boolean'); + ok(isbool($truevar), 'true var is boolean'); + + my $str = "$truevar"; + my $num = $truevar + 0; + + ok(!isbool($str), 'stringified true is not boolean'); + ok(!isbool($num), 'numified true is not boolean'); + + ok(isbool($truevar), 'true var remains boolean after stringification and numification'); +} + +# aggregate members +{ + my %hash = ( false => !!0, true => !!1 ); + + ok(isbool($hash{false}), 'false HELEM is boolean'); + ok(isbool($hash{true}), 'true HELEM is boolean'); + + # We won't test AELEM but it's likely to be the same +} + +{ + my $var; + package Foo { sub TIESCALAR { bless {}, shift } sub FETCH { $var } } + + tie my $tied, "Foo"; + + $var = 1; + ok(!isbool($tied), 'tied var should not yet be boolean'); + + $var = !!1; + ok(isbool($tied), 'tied var should now be boolean'); + + my $copy = $tied; + ok(isbool($copy), 'copy of tied var should also be boolean'); +} From 01c72c14679df9baa692d1eb8668d8712b3f9862 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Wed, 25 Aug 2021 14:34:29 +0100 Subject: [PATCH 5/9] Need to check also !defined(SvIsBOOL) to create varav --- cpan/Scalar-List-Utils/ListUtil.xs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs index 0c1385b60285..bd655010d509 100644 --- a/cpan/Scalar-List-Utils/ListUtil.xs +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -2114,7 +2114,7 @@ BOOT: HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE); SV *rmcsv; -#if !defined(SvWEAKREF) || !defined(SvVOK) +#if !defined(SvWEAKREF) || !defined(SvVOK) || !defined(SvIsBOOL) HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE); GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE); AV *varav; From 6a3be71e2956fb142ccd2b4bfada516a109e5b7d Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Wed, 25 Aug 2021 15:52:20 +0100 Subject: [PATCH 6/9] Have sv_dump() annotate when an SV's PV buffer is one of the PL_(Yes|No) special booleans --- dump.c | 2 ++ ext/Devel-Peek/t/Peek.t | 24 ++++++++++++++++++++++++ 2 files changed, 26 insertions(+) diff --git a/dump.c b/dump.c index c5c2d9e6ef43..8be8dd1ba7bb 100644 --- a/dump.c +++ b/dump.c @@ -1928,6 +1928,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ)); + if (SvIsBOOL(sv)) + PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No"); PerlIO_printf(file, "\n"); } Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index a8c68c80e60d..0580872b1e16 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -237,6 +237,30 @@ do_test('reference to scalar', COW_REFCNT = 1 '); +do_test('immediate boolean', + !!0, +'SV = PVNV\\($ADDR\\) at $ADDR + REFCNT = \d+ + FLAGS = \\(.*\\) + IV = 0 + NV = 0 + PV = $ADDR "" \[BOOL PL_No\] + CUR = 0 + LEN = 0 +') if $] >= 5.035004; + +do_test('assignment of boolean', + do { my $tmp = !!1 }, +'SV = PVNV\\($ADDR\\) at $ADDR + REFCNT = \d+ + FLAGS = \\(.*\\) + IV = 1 + NV = 1 + PV = $ADDR "1" \[BOOL PL_Yes\] + CUR = 1 + LEN = 0 +') if $] >= 5.035004; + my $c_pattern; if ($type eq 'N') { $c_pattern = ' From 7a0e6f2ac00a3d2cbb174ba79ade0ce86cc002a9 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Wed, 25 Aug 2021 14:59:39 +0100 Subject: [PATCH 7/9] Unit-test that booleaness is preserved on values passed in to, out of, or captured by threads --- MANIFEST | 1 + cpan/Scalar-List-Utils/t/boolean-thr.t | 38 ++++++++++++++++++++++++++ 2 files changed, 39 insertions(+) create mode 100644 cpan/Scalar-List-Utils/t/boolean-thr.t diff --git a/MANIFEST b/MANIFEST index 6a2740d9e0f8..5cc433a409c0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1978,6 +1978,7 @@ cpan/Scalar-List-Utils/t/00version.t Scalar::Util cpan/Scalar-List-Utils/t/any-all.t List::Util cpan/Scalar-List-Utils/t/blessed.t Scalar::Util cpan/Scalar-List-Utils/t/boolean.t Scalar::Util +cpan/Scalar-List-Utils/t/boolean-thr.t Scalar::Util cpan/Scalar-List-Utils/t/dualvar.t Scalar::Util cpan/Scalar-List-Utils/t/exotic_names.t cpan/Scalar-List-Utils/t/first.t List::Util diff --git a/cpan/Scalar-List-Utils/t/boolean-thr.t b/cpan/Scalar-List-Utils/t/boolean-thr.t new file mode 100644 index 000000000000..b46b4d50fdfe --- /dev/null +++ b/cpan/Scalar-List-Utils/t/boolean-thr.t @@ -0,0 +1,38 @@ +#!./perl + +use strict; +use warnings; + +use Config (); +use Scalar::Util (); +use Test::More + (grep { /isbool/ } @Scalar::Util::EXPORT_FAIL) ? (skip_all => 'isbool requires XS version') : + (!$Config::Config{usethreads}) ? (skip_all => 'perl does not support threads') : + (tests => 5); + +use threads; +use threads::shared; + +Scalar::Util->import("isbool"); + +ok(threads->create( sub { isbool($_[0]) }, !!0 )->join, + 'value in to thread is bool'); + +ok(isbool(threads->create( sub { return !!0 } )->join), + 'value out of thread is bool'); + +{ + my $var = !!0; + ok(threads->create( sub { isbool($var) } )->join, + 'variable captured by thread is bool'); +} + +{ + my $sharedvar :shared = !!0; + + ok(isbool($sharedvar), + ':shared variable is bool outside'); + + ok(threads->create( sub { isbool($sharedvar) } )->join, + ':shared variable is bool inside thread'); +} From 66ed910c3177020d888bab9990835fb004abc5d8 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Thu, 26 Aug 2021 11:14:29 +0100 Subject: [PATCH 8/9] Define sv_setbool() and sv_setbool_mg() macros --- sv.h | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/sv.h b/sv.h index e1853df3b13e..6d94927d10f4 100644 --- a/sv.h +++ b/sv.h @@ -2347,6 +2347,21 @@ See also C> and C>. #define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +/* +=for apidoc Am|void|sv_setbool|SV *sv|bool b +=for apidoc_item |void|sv_setbool_mg|SV *sv|bool b + +These set an SV to a true or false boolean value, upgrading first if necessary. + +They differ only in that C handles 'set' magic; C +does not. + +=cut +*/ + +#define sv_setbool(sv, b) sv_setsv(sv, boolSV(b)) +#define sv_setbool_mg(sv, b) sv_setsv_mg(sv, boolSV(b)) + #define isGV(sv) (SvTYPE(sv) == SVt_PVGV) /* If I give every macro argument a different name, then there won't be bugs where nested macros get confused. Been there, done that. */ From 5a09644b3cba3856ef161c8b5c77cfef6bbc2655 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Thu, 26 Aug 2021 11:50:30 +0100 Subject: [PATCH 9/9] Use sv_setbool() where appropriate --- ext/B/B.pm | 2 +- ext/B/B.xs | 2 +- ext/attributes/attributes.pm | 2 +- ext/attributes/attributes.xs | 2 +- gv.c | 2 +- pp_hot.c | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ext/B/B.pm b/ext/B/B.pm index ef23af6baa5f..9e6f2897c86b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.82'; + $B::VERSION = '1.83'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index e6e3fb830968..7cdd0f9c6a94 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -638,7 +638,7 @@ BOOT: cv = newXS("B::diehook", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, diehook); sv = get_sv("B::OP::does_parent", GV_ADDMULTI); - sv_setsv(sv, &PL_sv_yes); + sv_setbool(sv, TRUE); } void diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index c60f9406b994..4f613f40847c 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -1,6 +1,6 @@ package attributes; -our $VERSION = 0.33; +our $VERSION = 0.34; @EXPORT_OK = qw(get reftype); @EXPORT = (); diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs index 07b7b8dfe822..f2f28df93802 100644 --- a/ext/attributes/attributes.xs +++ b/ext/attributes/attributes.xs @@ -204,7 +204,7 @@ usage: Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv))); #if 0 /* this was probably a bad idea */ else if (SvPADMY(sv)) - sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */ + sv_setbool(TARG, FALSE); /* unblessed lexical */ #endif else { const HV *stash = NULL; diff --git a/gv.c b/gv.c index bde9c007bc28..ec96441dadbe 100644 --- a/gv.c +++ b/gv.c @@ -3172,7 +3172,7 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { able name. */ if (!SvOK(right)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); - sv_setsv_flags(left, &PL_sv_no, 0); + sv_setbool(left, FALSE); } else sv_setsv_flags(left, right, 0); SvGETMAGIC(right); diff --git a/pp_hot.c b/pp_hot.c index 17683ff0008f..37a605836a5d 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1083,7 +1083,7 @@ PP(pp_multiconcat) if (!SvOK(right)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); - sv_setsv_flags(left, &PL_sv_no, 0); + sv_setbool(left, FALSE); } else sv_setsv_flags(left, right, 0);