This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable - maintain boolean values
authorGraham Knop <haarg@haarg.org>
Thu, 16 Jun 2022 13:36:04 +0000 (15:36 +0200)
committerGraham Knop <haarg@haarg.org>
Fri, 24 Jun 2022 16:50:12 +0000 (18:50 +0200)
Add two new types to storable for boolean values. Use them to encode booleans
when possible. Decode as booleans which will maintain their boolean
status when possible.

MANIFEST
dist/Storable/Storable.xs
dist/Storable/t/boolean.t [new file with mode: 0644]
dist/Storable/t/malice.t

index 1248905..d4899f4 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3985,6 +3985,7 @@ dist/Storable/t/attach.t          Check STORABLE_attach doesn't create objects unnecessa
 dist/Storable/t/attach_errors.t                Trigger and test STORABLE_attach errors
 dist/Storable/t/attach_singleton.t     Test STORABLE_attach for the Singleton pattern
 dist/Storable/t/blessed.t              See if Storable works
+dist/Storable/t/boolean.t              See if Storable works
 dist/Storable/t/canonical.t            See if Storable works
 dist/Storable/t/circular_hook.t                Test thaw hook called depth-first for circular refs
 dist/Storable/t/code.t                 See if Storable works
index 5ace603..74d611c 100644 (file)
 #define SX_SVUNDEF_ELEM        C(31)   /* array element set to &PL_sv_undef */
 #define SX_REGEXP      C(32)   /* Regexp */
 #define SX_LOBJECT     C(33)   /* Large object: string, array or hash (size >2G) */
-#define SX_LAST                C(34)   /* invalid. marker only */
+#define SX_BOOLEAN_TRUE        C(34)   /* Boolean true */
+#define SX_BOOLEAN_FALSE       C(35)   /* Boolean false */
+#define SX_LAST                C(36)   /* invalid. marker only */
 
 /*
  * Those are only used to retrieve "old" pre-0.6 binary images.
@@ -973,7 +975,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 #endif
 
 #define STORABLE_BIN_MAJOR     2               /* Binary major "version" */
-#define STORABLE_BIN_MINOR     11              /* Binary minor "version" */
+#define STORABLE_BIN_MINOR     12              /* Binary minor "version" */
 
 #if !defined (SvVOK)
 /*
@@ -1452,6 +1454,8 @@ static const sv_retrieve_t sv_old_retrieve[] = {
     (sv_retrieve_t)retrieve_other,     /* SX_SVUNDEF_ELEM not supported */
     (sv_retrieve_t)retrieve_other,     /* SX_REGEXP */
     (sv_retrieve_t)retrieve_other,     /* SX_LOBJECT not supported */
+    (sv_retrieve_t)retrieve_other,     /* SX_BOOLEAN_TRUE not supported */
+    (sv_retrieve_t)retrieve_other,     /* SX_BOOLEAN_FALSE not supported */
     (sv_retrieve_t)retrieve_other,     /* SX_LAST */
 };
 
@@ -1475,6 +1479,8 @@ static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_boolean_true(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_boolean_false(pTHX_ stcxt_t *cxt, const char *cname);
 
 static const sv_retrieve_t sv_retrieve[] = {
     0,                                 /* SX_OBJECT -- entry unused dynamically */
@@ -1511,6 +1517,8 @@ static const sv_retrieve_t sv_retrieve[] = {
     (sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */
     (sv_retrieve_t)retrieve_regexp,    /* SX_REGEXP */
     (sv_retrieve_t)retrieve_lobject,   /* SX_LOBJECT */
+    (sv_retrieve_t)retrieve_boolean_true,      /* SX_BOOLEAN_TRUE */
+    (sv_retrieve_t)retrieve_boolean_false,     /* SX_BOOLEAN_FALSE */
     (sv_retrieve_t)retrieve_other,     /* SX_LAST */
 };
 
@@ -2452,6 +2460,16 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
             pv = SvPV(sv, len);                /* We know it's SvPOK */
             goto string;                       /* Share code below */
         }
+#ifdef SvIsBOOL
+    } else if (SvIsBOOL(sv)) {
+        TRACEME(("mortal boolean"));
+        if (SvTRUE_nomg_NN(sv)) {
+            PUTMARK(SX_BOOLEAN_TRUE);
+        }
+        else {
+            PUTMARK(SX_BOOLEAN_FALSE);
+        }
+#endif
     } else if (flags & SVf_POK) {
         /* public string - go direct to string read.  */
         goto string_readlen;
@@ -5881,6 +5899,50 @@ static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
 }
 
 /*
+ * retrieve_boolean_true
+ *
+ * Retrieve boolean true copy.
+ */
+static SV *retrieve_boolean_true(pTHX_ stcxt_t *cxt, const char *cname)
+{
+    SV *sv;
+    HV *stash;
+
+    TRACEME(("retrieve_boolean_true (#%d)", (int)cxt->tagnum));
+
+    sv = newSVsv(&PL_sv_yes);
+    stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+    SEEN_NN(sv, stash, 0);  /* Associate this new scalar with tag "tagnum" */
+
+    TRACEME(("boolean true"));
+    TRACEME(("ok (retrieve_boolean_true at 0x%" UVxf ")", PTR2UV(sv)));
+
+    return sv;
+}
+
+/*
+ * retrieve_boolean_false
+ *
+ * Retrieve boolean false copy.
+ */
+static SV *retrieve_boolean_false(pTHX_ stcxt_t *cxt, const char *cname)
+{
+    SV *sv;
+    HV *stash;
+
+    TRACEME(("retrieve_boolean_true (#%d)", (int)cxt->tagnum));
+
+    sv = newSVsv(&PL_sv_no);
+    stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+    SEEN_NN(sv, stash, 0);  /* Associate this new scalar with tag "tagnum" */
+
+    TRACEME(("boolean false"));
+    TRACEME(("ok (retrieve_boolean_false at 0x%" UVxf ")", PTR2UV(sv)));
+
+    return sv;
+}
+
+/*
  * retrieve_lobject
  *
  * Retrieve overlong scalar, array or hash.
diff --git a/dist/Storable/t/boolean.t b/dist/Storable/t/boolean.t
new file mode 100644 (file)
index 0000000..9ba19c0
--- /dev/null
@@ -0,0 +1,84 @@
+use strict;
+use warnings;
+
+my $true_ref;
+my $false_ref;
+BEGIN {
+    $true_ref = \!!1;
+    $false_ref = \!!0;
+}
+
+BEGIN {
+    unshift @INC, 't';
+    unshift @INC, 't/compat' if $] < 5.006002;
+    require Config;
+    if ($ENV{PERL_CORE} and $Config::Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 12;
+use Storable qw(thaw freeze);
+
+use constant CORE_BOOLS => defined &builtin::is_bool;
+
+{
+  my $x = $true_ref;
+  my $y = ${thaw freeze \$x};
+  is($y, $x);
+  eval {
+    $$y = 2;
+  };
+  isnt $@, '',
+    'immortal true maintained as immortal';
+}
+
+{
+  my $x = $false_ref;
+  my $y = ${thaw freeze \$x};
+  is($y, $x);
+  eval {
+    $$y = 2;
+  };
+  isnt $@, '',
+    'immortal false maintained as immortal';
+}
+
+{
+  my $true = $$true_ref;
+  my $x = \$true;
+  my $y = ${thaw freeze \$x};
+  is($$y, $$x);
+  is($$y, '1');
+  SKIP: {
+    skip "perl $] does not support tracking boolean values", 1
+      unless CORE_BOOLS;
+    BEGIN { CORE_BOOLS and warnings->unimport('experimental::builtin') }
+    ok builtin::is_bool($$y);
+  }
+  eval {
+    $$y = 2;
+  };
+  is $@, '',
+    'mortal true maintained as mortal';
+}
+
+{
+  my $false = $$false_ref;
+  my $x = \$false;
+  my $y = ${thaw freeze \$x};
+  is($$y, $$x);
+  is($$y, '');
+  SKIP: {
+    skip "perl $] does not support tracking boolean values", 1
+      unless CORE_BOOLS;
+    BEGIN { CORE_BOOLS and warnings->unimport('experimental::builtin') }
+    ok builtin::is_bool($$y);
+  }
+  eval {
+    $$y = 2;
+  };
+  is $@, '',
+    'mortal true maintained as mortal';
+}
index 8adae95..7b92d3d 100644 (file)
@@ -32,7 +32,7 @@ our $file_magic_str = 'pst0';
 our $other_magic = 7 + length $byteorder;
 our $network_magic = 2;
 our $major = 2;
-our $minor = 11;
+our $minor = 12;
 our $minor_write = $] >= 5.019 ? 11 : $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4;
 
 use Test::More;
@@ -206,7 +206,7 @@ sub test_things {
     $where = $file_magic + $network_magic;
   }
 
-  # Just the header and a tag 255. As 33 is currently the highest tag, this
+  # Just the header and a tag 255. As 34 is currently the highest tag, this
   # is "unexpected"
   $copy = substr ($contents, 0, $where) . chr 255;
 
@@ -226,7 +226,7 @@ sub test_things {
   # local $Storable::DEBUGME = 1;
   # This is the delayed croak
   test_corrupt ($copy, $sub,
-                "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 33/",
+                "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 35/",
                 "bogus tag, minor plus 4");
   # And check again that this croak is not delayed:
   {