From fd2e79041c553c1220c6eca796293873246c5682 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Wed, 6 May 2015 09:39:53 +0200
Subject: [PATCH] Upgrade to 2.53
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ChangeLog | 2 +-
MANIFEST | 3 +++
Storable.pm | 6 +++---
t/attach.t | 42 ++++++++++++++++++++++++++++++++++++
t/attach_errors.t | 2 +-
t/canonical.t | 2 +-
t/code.t | 2 +-
t/leaks.t | 34 +++++++++++++++++++++++++++++
t/tied_store.t | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
t/utf8.t | 6 ++++--
10 files changed, 154 insertions(+), 9 deletions(-)
create mode 100644 t/attach.t
create mode 100644 t/leaks.t
create mode 100644 t/tied_store.t
diff --git a/ChangeLog b/ChangeLog
index 4df921e..cbfdbab 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -209,7 +209,7 @@ Fri Jun 7 23:55:41 BST 2002 Nicholas Clark
The bug was introduced as development perl change 16442 (on
2002/05/07), so has been present since 2.00.
Patches to introduce more regression tests to reduce the chance of
- a reoccurence of this sort of goof are always welcome.
+ a reoccurrence of this sort of goof are always welcome.
Thu May 30 20:31:08 BST 2002 Nicholas Clark <nick@ccl4.org>
diff --git a/MANIFEST b/MANIFEST
index 84b72f1..2f5b725 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -9,6 +9,7 @@ ppport.h
README
Storable.pm
Storable.xs
+t/attach.t
t/attach_errors.t
t/attach_singleton.t
t/blessed.t
@@ -33,6 +34,7 @@ t/HAS_OVERLOAD.pm
t/integer.t
t/interwork56.t
t/just_plain_nasty.t
+t/leaks.t
t/lock.t
t/make_56_interwork.pl
t/make_downgrade.pl
@@ -51,6 +53,7 @@ t/threads.t
t/tied.t
t/tied_hook.t
t/tied_items.t
+t/tied_store.t
t/utf8.t
t/utf8hash.t
t/weak.t
diff --git a/Storable.pm b/Storable.pm
index 839c1d1..9d8b621 100644
--- a/Storable.pm
+++ b/Storable.pm
@@ -22,7 +22,7 @@ package Storable; @ISA = qw(Exporter);
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.51';
+$VERSION = '2.53';
BEGIN {
if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
@@ -1088,8 +1088,8 @@ deal with them.
The store functions will C<croak> if they run into such references
unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
-case, the fatal message is turned in a warning and some
-meaningless string is stored instead.
+case, the fatal message is converted to a warning and some meaningless
+string is stored instead.
Setting C<$Storable::canonical> may not yield frozen strings that
compare equal due to possible stringification of numbers. When the
diff --git a/t/attach.t b/t/attach.t
new file mode 100644
index 0000000..5ffdae5
--- /dev/null
+++ b/t/attach.t
@@ -0,0 +1,42 @@
+#!./perl -w
+#
+# This file tests that Storable correctly uses STORABLE_attach hooks
+
+sub BEGIN {
+ unshift @INC, 't';
+ unshift @INC, 't/compat' if $] < 5.006002;
+ require Config; import Config;
+ if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 3;
+use Storable ();
+
+{
+ my $destruct_cnt = 0;
+ my $obj = bless {data => 'ok'}, 'My::WithDestructor';
+ my $target = Storable::thaw( Storable::freeze( $obj ) );
+ is( $target->{data}, 'ok', 'We got correct object after freeze/thaw' );
+ is( $destruct_cnt, 0, 'No tmp objects created by Storable' );
+ undef $obj;
+ undef $target;
+ is( $destruct_cnt, 2, 'Only right objects destroyed at the end' );
+
+ package My::WithDestructor;
+
+ sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+ return $self->{data};
+ }
+
+ sub STORABLE_attach {
+ my ($class, $clone, $string) = @_;
+ return bless {data => $string}, 'My::WithDestructor';
+ }
+
+ sub DESTROY { $destruct_cnt++; }
+}
+
diff --git a/t/attach_errors.t b/t/attach_errors.t
index c163ca0..6cebd97 100644
--- a/t/attach_errors.t
+++ b/t/attach_errors.t
@@ -234,7 +234,7 @@ use Storable ();
isa_ok( $thawed->[1], 'My::GoodAttach::MultipleReferences' );
is($thawed->[0], $thawed->[1], 'References to the same object are attached properly');
- is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attchached properly');
+ is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attached properly');
package My::GoodAttach::MultipleReferences;
diff --git a/t/canonical.t b/t/canonical.t
index 23e012f..35046de 100644
--- a/t/canonical.t
+++ b/t/canonical.t
@@ -34,7 +34,7 @@ $maxarraysize = 100;
eval { require Digest::MD5; };
$gotmd5 = !$@;
-diag "Will use Digest::MD5" if $gotmd5;
+note "Will use Digest::MD5" if $gotmd5;
# Use Data::Dumper if debugging and it is available to create an ASCII dump
diff --git a/t/code.t b/t/code.t
index c383142..7fc40ba 100644
--- a/t/code.t
+++ b/t/code.t
@@ -102,7 +102,7 @@ is($thawed->{"b"}->(), "JAPH");
$freezed = freeze $obj[2];
$thawed = thaw $freezed;
-is($thawed->(), 42);
+is($thawed->(), (ord "A") == 193 ? -118 : 42);
######################################################################
diff --git a/t/leaks.t b/t/leaks.t
new file mode 100644
index 0000000..06360d6
--- /dev/null
+++ b/t/leaks.t
@@ -0,0 +1,34 @@
+#!./perl
+
+use Test::More;
+use Storable ();
+BEGIN {
+eval "use Test::LeakTrace";
+plan 'skip_all' => 'Test::LeakTrace required for this tests' if $@;
+}
+plan 'tests' => 1;
+
+{
+ my $c = My::Simple->new;
+ my $d;
+ my $freezed = Storable::freeze($c);
+ no_leaks_ok
+ {
+ $d = Storable::thaw($freezed);
+ undef $d;
+ };
+
+ package My::Simple;
+ sub new {
+ my ($class, $arg) = @_;
+ bless {t=>$arg}, $class;
+ }
+ sub STORABLE_freeze {
+ return "abcderfgh";
+ }
+ sub STORABLE_attach {
+ my ($class, $c, $serialized) = @_;
+ return $class->new($serialized);
+ }
+}
+
diff --git a/t/tied_store.t b/t/tied_store.t
new file mode 100644
index 0000000..c657f95
--- /dev/null
+++ b/t/tied_store.t
@@ -0,0 +1,64 @@
+#!./perl
+
+sub BEGIN {
+ unshift @INC, 't';
+ unshift @INC, 't/compat' if $] < 5.006002;
+ require Config; import Config;
+ if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Storable ();
+use Test::More tests => 3;
+
+our $f;
+
+package TIED_HASH;
+
+sub TIEHASH { bless({}, $_[0]) }
+
+sub STORE {
+ $f = Storable::freeze(\$_[2]);
+ 1;
+}
+
+package TIED_ARRAY;
+
+sub TIEARRAY { bless({}, $_[0]) }
+
+sub STORE {
+ $f = Storable::freeze(\$_[2]);
+ 1;
+}
+
+package TIED_SCALAR;
+
+sub TIESCALAR { bless({}, $_[0]) }
+
+sub STORE {
+ $f = Storable::freeze(\$_[1]);
+ 1;
+}
+
+package main;
+
+my($s, @a, %h);
+tie $s, "TIED_SCALAR";
+tie @a, "TIED_ARRAY";
+tie %h, "TIED_HASH";
+
+$f = undef;
+$s = 111;
+is $f, Storable::freeze(\111);
+
+$f = undef;
+$a[3] = 222;
+is $f, Storable::freeze(\222);
+
+$f = undef;
+$h{foo} = 333;
+is $f, Storable::freeze(\333);
+
+1;
diff --git a/t/utf8.t b/t/utf8.t
index fd20ef6..a8dd6cd 100644
--- a/t/utf8.t
+++ b/t/utf8.t
@@ -32,8 +32,10 @@ is($x, ${thaw freeze \$x});
$x = join '', map {chr $_} (0..1023);
is($x, ${thaw freeze \$x});
-# Char in the range 127-255 (probably) in utf8
-$x = chr (175) . chr (256);
+# Char in the range 127-255 (probably) in utf8. This just won't work for
+# EBCDIC for early Perls.
+$x = ($] lt 5.007_003) ? chr(175) : chr(utf8::unicode_to_native(175))
+ . chr (256);
chop $x;
is($x, ${thaw freeze \$x});
--
2.1.0