Add a Scalar::Util::isbool()

Remember to SvGETMAGIC() before testing SvIsBOOL() (thanks @tonycoz)

Unit-test that booleaness is preserved on values passed in to, out of, or captured by threads

7 files changed, 149 insertions, 9 deletions

diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs
index 2ce9085569..bd655010d5 100644
--- a/cpan/Scalar-List-Utils/ListUtil.xs
+++ b/cpan/Scalar-List-Utils/ListUtil.xs
@@ -1666,6 +1666,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
     SV *str
@@ -2101,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;
@@ -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 dad5357f43..71f36f1956 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 70d33131cc..77cb68fc97 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 de3e892298..feb59806c6 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
@@ -38,12 +40,17 @@ unless (defined &isvstring) {
 sub export_fail {
   if (grep { /^(?:weaken|isweak)$/ } @_ ) {
     require Carp;
-    Carp::croak("Weak references are not implemented in the version of perl");
+    Carp::croak("Weak references are not implemented in this version of perl");
   }
 
   if (grep { /^isvstring$/ } @_ ) {
     require Carp;
-    Carp::croak("Vstrings are not implemented in the version of perl");
+    Carp::croak("Vstrings are not implemented in this version of perl");
+  }
+
+  if (grep { /^isbool$/ } @_ ) {
+    require Carp;
+    Carp::croak("isbool is not implemented in this version of perl");
   }
 
   @_;
@@ -217,6 +224,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 );
@@ -324,16 +341,21 @@ Module use may give one of the following errors during import.
 
 =over
 
-=item Weak references are not implemented in the version of perl
+=item Weak references are not implemented in this version of perl
 
 The version of perl that you are using does not implement weak references, to
 use L</isweak> or L</weaken> you will need to use a newer release of perl.
 
-=item Vstrings are not implemented in the version of perl
+=item Vstrings are not implemented in this version of perl
 
 The version of perl that you are using does not implement Vstrings, to use
 L</isvstring> you will need to use a newer release of perl.
 
+=item isbool is not implemented in this version of perl
+
+The version of perl that you are using does not implement stable boolean
+tracking, to use L</isbool> you will need to use a newer release of perl.
+
 =back
 
 =head1 KNOWN BUGS
diff --git a/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/cpan/Scalar-List-Utils/lib/Sub/Util.pm
index 1eee0ded41..8b25af7544 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-thr.t b/cpan/Scalar-List-Utils/t/boolean-thr.t
new file mode 100644
index 0000000000..4b4073948c
--- /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 is not supported on this perl') :
+    (!$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');
+}
diff --git a/cpan/Scalar-List-Utils/t/boolean.t b/cpan/Scalar-List-Utils/t/boolean.t
new file mode 100644
index 0000000000..f543fa450c
--- /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 is not supported on this perl')
+    : (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');
+}