rpms
/
perl-Storable
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Upgrade to 3.31 as provided in perl-5.37.11

This commit is contained in:
Jitka Plesnikova 2023-05-18 17:27:49 +02:00
parent 5c92e0f935
commit 495a2c78ff
2 changed files with 437 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

425
Storable-3.26-Upgrade-to-3.31.patch Normal file
View File

@ -0,0 +1,425 @@
From c898c00503adcf74e9d6b96c3c6feb2539a19664 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Thu, 18 May 2023 17:12:30 +0200
Subject: [PATCH] Upgrade to 3.31
---
Storable.pm | 2 +-
Storable.xs | 107 ++++++++++++++++++++++++++++++++++++++++++----------
t/blessed.t | 53 +++++++++++++++++++++++++-
t/boolean.t | 84 +++++++++++++++++++++++++++++++++++++++++
t/malice.t | 6 +--
5 files changed, 228 insertions(+), 24 deletions(-)
create mode 100644 t/boolean.t
diff --git a/Storable.pm b/Storable.pm
index ef417c6..32fd772 100644
--- a/Storable.pm
+++ b/Storable.pm
@@ -28,7 +28,7 @@ our @EXPORT_OK = qw(
our ($canonical, $forgive_me);
BEGIN {
- our $VERSION = '3.26';
+ our $VERSION = '3.31';
}
our $recursion_limit;
diff --git a/Storable.xs b/Storable.xs
index 53c838c..a558dd7 100644
--- a/Storable.xs
+++ b/Storable.xs
@@ -16,18 +16,13 @@
#include <perl.h>
#include <XSUB.h>
-#ifndef PERL_VERSION_LT
-# if !defined(PERL_VERSION) || !defined(PERL_REVISION) || ( PERL_REVISION == 5 && ( PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1) ) )
-# define NEED_PL_parser
-# define NEED_sv_2pv_flags
-# define NEED_load_module
-# define NEED_vload_module
-# define NEED_newCONSTSUB
-# define NEED_newSVpvn_flags
-# define NEED_newRV_noinc
-# endif
+#define NEED_sv_2pv_flags
+#define NEED_load_module
+#define NEED_vload_module
+#define NEED_newCONSTSUB
+#define NEED_newSVpvn_flags
+#define NEED_newRV_noinc
#include "ppport.h" /* handle old perls */
-#endif
#ifdef DEBUGGING
#define DEBUGME /* Debug mode, turns assertions on as well */
@@ -176,7 +171,9 @@
#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.
@@ -975,7 +972,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)
/*
@@ -1454,6 +1451,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 */
};
@@ -1477,6 +1476,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 */
@@ -1513,6 +1514,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 */
};
@@ -2454,6 +2457,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;
@@ -3250,6 +3263,7 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
text = POPs;
+ PUTBACK;
len = SvCUR(text);
reallen = strlen(SvPV_nolen(text));
@@ -3567,7 +3581,10 @@ static int store_hook(
int need_large_oids = 0;
#endif
- TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), (int)cxt->tagnum));
+ classname = HvNAME_get(pkg);
+ len = strlen(classname);
+
+ TRACEME(("store_hook, classname \"%s\", tagged #%d", classname, (int)cxt->tagnum));
/*
* Determine object type on 2 bits.
@@ -3576,6 +3593,7 @@ static int store_hook(
switch (type) {
case svis_REF:
case svis_SCALAR:
+ case svis_REGEXP:
obj_type = SHT_SCALAR;
break;
case svis_ARRAY:
@@ -3615,13 +3633,20 @@ static int store_hook(
}
break;
default:
- CROAK(("Unexpected object type (%d) in store_hook()", type));
+ {
+ /* pkg_can() always returns a ref to a CV on success */
+ CV *cv = (CV*)SvRV(hook);
+ const GV * const gv = CvGV(cv);
+ const char *gvname = GvNAME(gv);
+ const HV * const stash = GvSTASH(gv);
+ const char *hvname = stash ? HvNAME(stash) : NULL;
+
+ CROAK(("Unexpected object type (%s) of class '%s' in store_hook() calling %s::%s",
+ sv_reftype(sv, FALSE), classname, hvname, gvname));
+ }
}
flags = SHF_NEED_RECURSE | obj_type;
- classname = HvNAME_get(pkg);
- len = strlen(classname);
-
/*
* To call the hook, we need to fake a call like:
*
@@ -5882,6 +5907,50 @@ static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
return sv;
}
+/*
+ * 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_false (#%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
*
@@ -7774,7 +7843,7 @@ CODE:
assert(cxt);
result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
} else {
- result = !!last_op_in_netorder(aTHX);
+ result = cBOOL(last_op_in_netorder(aTHX));
}
ST(0) = boolSV(result);
diff --git a/t/blessed.t b/t/blessed.t
index d9a77b3..dea569b 100644
--- a/t/blessed.t
+++ b/t/blessed.t
@@ -44,7 +44,7 @@ use Storable qw(freeze thaw store retrieve fd_retrieve);
'long VSTRING' => \(my $lvstring = eval "v" . 0 x 300),
LVALUE => \(my $substr = substr((my $str = "foo"), 0, 3)));
-my $test = 13;
+my $test = 18;
my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs);
plan(tests => $tests);
@@ -414,3 +414,54 @@ is(ref $t, 'STRESS_THE_STACK');
unlink("store$$");
}
+
+{
+ # trying to freeze a glob via STORABLE_freeze
+ {
+ package GlobHookedBase;
+
+ sub STORABLE_freeze {
+ return \1;
+ }
+
+ package GlobHooked;
+ our @ISA = "GlobHookedBase";
+ }
+ use Symbol ();
+ my $glob = bless Symbol::gensym(), "GlobHooked";
+ eval {
+ my $data = freeze($glob);
+ };
+ my $msg = $@;
+ like($msg, qr/Unexpected object type \(GLOB\) of class 'GlobHooked' in store_hook\(\) calling GlobHookedBase::STORABLE_freeze/,
+ "check we get the verbose message");
+}
+
+SKIP:
+{
+ $] < 5.012
+ and skip "Can't assign regexps directly before 5.12", 4;
+ my $hook_called;
+ # store regexp via hook
+ {
+ package RegexpHooked;
+ sub STORABLE_freeze {
+ ++$hook_called;
+ "$_[0]";
+ }
+ sub STORABLE_thaw {
+ my ($obj, $cloning, $serialized) = @_;
+ ++$hook_called;
+ $$obj = ${ qr/$serialized/ };
+ }
+ }
+
+ my $obj = bless qr/abc/, "RegexpHooked";
+ my $data = freeze($obj);
+ ok($data, "froze regexp blessed into hooked class");
+ ok($hook_called, "and the hook was actually called");
+ $hook_called = 0;
+ my $obj_thawed = thaw($data);
+ ok($hook_called, "hook called for thaw");
+ like("abc", $obj_thawed, "check the regexp");
+}
diff --git a/t/boolean.t b/t/boolean.t
new file mode 100644
index 0000000..9ba19c0
--- /dev/null
+++ b/t/boolean.t
@@ -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';
+}
diff --git a/t/malice.t b/t/malice.t
index 8adae95..7b92d3d 100644
--- a/t/malice.t
+++ b/t/malice.t
@@ -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:
{
--
2.40.1

17
perl-Storable.spec
View File

@ -1,8 +1,8 @@
%global base_version 3.25
Name: perl-Storable
Epoch: 1
Version: 3.26
Release: 490%{?dist}
Version: 3.31
Release: 1%{?dist}
Summary: Persistence for Perl data structures
# Storable.pm: GPL+ or Artistic
License: GPL-1.0-or-later OR Artistic-1.0-Perl
@ -10,6 +10,8 @@ URL: https://metacpan.org/release/Storable
Source0: https://cpan.metacpan.org/authors/id/N/NW/NWCLARK/Storable-%{base_version}.tar.gz
# Unbundled from perl 5.35.11
Patch0: Storable-3.25-Upgrade-to-3.26.patch
# Unbundled from perl 5.37.11
Patch1: Storable-3.26-Upgrade-to-3.31.patch
BuildRequires: coreutils
BuildRequires: gcc
BuildRequires: make
@ -36,6 +38,7 @@ BuildRequires: perl(XSLoader)
# Tests:
BuildRequires: perl(base)
BuildRequires: perl(bytes)
BuildRequires: perl(constant)
BuildRequires: perl(File::Temp)
BuildRequires: perl(integer)
BuildRequires: perl(overload)
@ -44,6 +47,7 @@ BuildRequires: perl(Test::More)
BuildRequires: perl(threads)
BuildRequires: perl(Safe)
BuildRequires: perl(Scalar::Util)
BuildRequires: perl(Symbol)
BuildRequires: perl(Tie::Array)
# Optional tests:
# gzip not used
@ -78,7 +82,6 @@ Requires: %{name} = %{?epoch:%{epoch}:}%{version}-%{release}
Requires: perl-Test-Harness
Requires: perl(B::Deparse) >= 0.61
Requires: perl(Digest::MD5)
Requires: perl(Hash::Util)
%description tests
Tests from %{name}. Execute them
@ -86,7 +89,8 @@ with "%{_libexecdir}/%{name}/test".
%prep
%setup -q -n Storable-%{base_version}
%patch0 -p1
%patch -P0 -p1
%patch -P1 -p1
# Help generators to recognize Perl scripts
for F in t/*.t t/*.pl; do
@ -130,12 +134,15 @@ make test
%doc ChangeLog README
%{perl_vendorarch}/auto/*
%{perl_vendorarch}/Storable*
%{_mandir}/man3/*
%{_mandir}/man3/Storable*
%files tests
%{_libexecdir}/%{name}
%changelog
* Thu May 18 2023 Jitka Plesnikova <jplesnik@redhat.com> - 1:3.31-1
- Upgrade to 3.31 as provided in perl-5.37.11
* Fri Jan 20 2023 Fedora Release Engineering <releng@fedoraproject.org> - 1:3.26-490
- Rebuilt for https://fedoraproject.org/wiki/Fedora_38_Mass_Rebuild