diff options
Diffstat (limited to 'ext/Storable')
| -rw-r--r-- | ext/Storable/MANIFEST | 1 | ||||
| -rw-r--r-- | ext/Storable/Storable.pm | 2 | ||||
| -rw-r--r-- | ext/Storable/Storable.xs | 20 | ||||
| -rw-r--r-- | ext/Storable/t/compat01.t | 56 |
4 files changed, 74 insertions, 5 deletions
diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST index c12ecb56fd..8fc574e824 100644 --- a/ext/Storable/MANIFEST +++ b/ext/Storable/MANIFEST @@ -15,6 +15,7 @@ t/blessed.t See if Storable works t/canonical.t See if Storable works t/circular_hook.t Test thaw hook called depth-first for circular refs t/code.t Test (de)serialization of code references +t/compat01.t See if Storable is compatible with v0.1 and v0.4 dumps t/compat06.t See if Storable works t/croak.t See if Storable works t/dclone.t See if Storable works diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 712f597747..1e0f5905b4 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter DynaLoader); use AutoLoader; use vars qw($canonical $forgive_me $VERSION); -$VERSION = '2.15_01'; +$VERSION = '2.15_02'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index b4c1f6a2a1..a2e2d5a134 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -5641,6 +5641,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) int length; int use_network_order; int use_NV_size; + int old_magic = 0; int version_major; int version_minor = 0; @@ -5674,6 +5675,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) if (memNE(buf, old_magicstr, old_len)) CROAK(("File is not a perl storable")); + old_magic++; current = buf + old_len; } use_network_order = *current; @@ -5685,9 +5687,14 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) * indicate the version number of the binary, and therefore governs the * setting of sv_retrieve_vtbl. See magic_write(). */ - - version_major = use_network_order >> 1; - cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major ? sv_retrieve : sv_old_retrieve); + if (old_magic && use_network_order > 1) { + /* 0.1 dump - use_network_order is really byte order length */ + version_major = -1; + } + else { + version_major = use_network_order >> 1; + } + cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve); TRACEME(("magic_check: netorder = 0x%x", use_network_order)); @@ -5750,7 +5757,12 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) /* In C truth is 1, falsehood is 0. Very convienient. */ use_NV_size = version_major >= 2 && version_minor >= 2; - GETMARK(c); + if (version_major >= 0) { + GETMARK(c); + } + else { + c = use_network_order; + } length = c + 3 + use_NV_size; READ(buf, length); /* Not null-terminated */ diff --git a/ext/Storable/t/compat01.t b/ext/Storable/t/compat01.t new file mode 100644 index 0000000000..536d85ed7b --- /dev/null +++ b/ext/Storable/t/compat01.t @@ -0,0 +1,56 @@ +#!perl -w + +BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = ('.', '../lib', '../ext/Storable/t'); + } else { + unshift @INC, 't'; + } + 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 Config; + if ($Config{byteorder} ne "1234") { + print "1..0 # Skip: Test only works for 32 bit little-ending machines\n"; + exit 0; + } +} + +use strict; +use Storable qw(retrieve); + +my $file = "xx-$$.pst"; +my @dumps = ( + # some sample dumps of the hash { one => 1 } + "perl-store\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\1\1\0\0\x001Xk\3\0\0\0oneX", # 0.1 + "perl-store\0\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\b\x81Xk\3\0\0\0oneX", # 0.4@7 +); + +print "1.." . @dumps . "\n"; + +my $testno; +for my $dump (@dumps) { + $testno++; + + open(FH, ">$file") || die "Can't create $file: $!"; + binmode(FH); + print FH $dump; + close(FH) || die "Can't write $file: $!"; + + eval { + my $data = retrieve($file); + if (ref($data) eq "HASH" && $data->{one} eq "1") { + print "ok $testno\n"; + } + else { + print "not ok $testno\n"; + } + }; + warn $@ if $@; + + unlink($file); +} |