Skip to content

Commit

Permalink
Merge 339e7af into b00088e
Browse files Browse the repository at this point in the history
  • Loading branch information
leonerd committed Aug 21, 2021
2 parents b00088e + 339e7af commit 07630db
Show file tree
Hide file tree
Showing 10 changed files with 181 additions and 19 deletions.
2 changes: 2 additions & 0 deletions MANIFEST
Expand Up @@ -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
Expand Down Expand Up @@ -5828,6 +5829,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
Expand Down
16 changes: 16 additions & 0 deletions cpan/Scalar-List-Utils/ListUtil.xs
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion cpan/Scalar-List-Utils/lib/List/Util.pm
Expand Up @@ -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;

Expand Down
2 changes: 1 addition & 1 deletion cpan/Scalar-List-Utils/lib/List/Util/XS.pm
Expand Up @@ -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;
Expand Down
14 changes: 13 additions & 1 deletion cpan/Scalar-List-Utils/lib/Scalar/Util.pm
Expand Up @@ -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
Expand Down Expand Up @@ -217,6 +219,16 @@ B<NOTE>: Copying a weak reference creates a normal, strong, reference.
=head1 OTHER FUNCTIONS
=head2 isbool
my $bool = isbool( $var );
I<Available only since perl 5.35.3 onwards.>
Returns true if the given variable is boolean in nature - that is, it is the
result of a boolean operator (such as C<defined>, C<exists>, or a numerical or
string comparison), or is a variable that is copied from one.
=head2 dualvar
my $var = dualvar( $num, $string );
Expand Down
2 changes: 1 addition & 1 deletion cpan/Scalar-List-Utils/lib/Sub/Util.pm
Expand Up @@ -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
Expand Down
64 changes: 64 additions & 0 deletions 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');
}
39 changes: 28 additions & 11 deletions sv.c
Expand Up @@ -4660,6 +4660,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
SvPV_free(dsv);
}

if (SvIsCOW_static(ssv)) {
SvPV_set(dsv, SvPVX(ssv));
SvLEN_set(dsv, 0);
SvCUR_set(dsv, cur);
SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
}
else
#ifdef PERL_ANY_COW
if (len) {
if (sflags & SVf_IsCOW) {
Expand Down Expand Up @@ -4808,6 +4815,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
Expand Down Expand Up @@ -4836,14 +4844,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 {
Expand All @@ -4863,7 +4876,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);
Expand Down Expand Up @@ -5155,6 +5168,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) {
Expand Down Expand Up @@ -5199,7 +5213,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
Expand Down Expand Up @@ -6771,17 +6785,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));
Expand Down Expand Up @@ -14062,7 +14079,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)),
Expand Down Expand Up @@ -15988,13 +16005,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;
Expand Down
22 changes: 18 additions & 4 deletions sv.h
Expand Up @@ -462,6 +462,8 @@ perform the upgrade if necessary. See C<L</svtype>>.
/* 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 */
Expand Down Expand Up @@ -1049,6 +1051,17 @@ 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.
*/

#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
Expand Down Expand Up @@ -2008,10 +2021,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)))
Expand Down
37 changes: 37 additions & 0 deletions 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();

0 comments on commit 07630db

Please sign in to comment.