From fd2e79041c553c1220c6eca796293873246c5682 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= 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ř --- 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 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 if they run into such references unless you set C<$Storable::forgive_me> to some C 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