Storable 0.1 compatibility

Message-ID: <lry83v712y.fsf@caliper.activestate.com>

Also added an entry in the main MANIFEST file for the new test and
a version bump in Storable.pm.

p4raw-id: //depot/perl@26087

diff --git a/MANIFEST b/MANIFEST
index 886778e..6d6231a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -892,6 +892,7 @@ ext/Storable/t/blessed.t    See if Storable works
 ext/Storable/t/canonical.t     See if Storable works
 ext/Storable/t/circular_hook.t Test thaw hook called depth-first for circular refs
 ext/Storable/t/code.t          See if Storable works
+ext/Storable/t/compat01.t      See if Storable works
 ext/Storable/t/compat06.t      See if Storable works
 ext/Storable/t/croak.t         See if Storable works
 ext/Storable/t/dclone.t                See if Storable works

diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST
index c12ecb5..8fc574e 100644 (file)
--- 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 712f597..1e0f590 100644 (file)
--- 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 b4c1f6a..a2e2d5a 100644 (file)
--- 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 (file)
index 0000000..536d85e
--- /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);
+}