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

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);
+}