Re: perl@16433

Message-ID: <20020506232146.GF4698@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@16437

diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index ea6080b..e6d5269 100644 (file)
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -102,6 +102,7 @@ sub retrieve_fd { &fd_retrieve }            # Backward compatibility
 # By default restricted hashes are downgraded on earlier perls.
 
 $Storable::downgrade_restricted = 1;
+$Storable::accept_future_minor = 1;
 bootstrap Storable;
 1;
 __END__
@@ -590,6 +591,25 @@ placeholder keys and leaving the keys and all values unlocked.  To make
 Storable C<croak()> instead, set C<$Storable::downgrade_restricted> to
 a false value.  To restore the default set it back to some C<TRUE> value.
 
+=item files from future versions of Storable
+
+Earlier versions of Storable would immediately croak if they encountered
+a file with a higher internal version number than the reading Storable
+knew about.  Internal version numbers are increased each time new data
+types (such as restricted hashes) are added to the vocabulary of the file
+format.  This meant that a newer Storable module had no way of writing a
+file readable by an older Storable, even if writer didn't store newer
+data types.
+
+This version of Storable will defer croaking until it encounters a data
+type in the file that it does not recognize.  This means that it will
+continue to read files generated by newer Storable modules which are careful
+in what they write out, making it easier to upgrade Storable modules in a
+mixed environment.
+
+The old behaviour of immediate croaking can be re-instated by setting
+C<$Storable::accept_future_minor> to false.
+
 =back
 
 Both these variables have no effect on a newer Perl which supports the

diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 05705c0..332ed70 100644 (file)
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -59,7 +59,7 @@
 #include <XSUB.h>
 
 #ifndef NETWARE
-#if 1
+#if 0
 #define DEBUGME /* Debug mode, turns assertions on as well */
 #define DASSERT /* Assertion mode */
 #endif
@@ -339,6 +339,7 @@ typedef struct stcxt {
 #ifndef HAS_UTF8_ALL
         int use_bytes;         /* whether to bytes-ify utf8 */
 #endif
+        int accept_future_minor; /* croak immediately on future minor versions?  */
        int s_dirty;            /* context is dirty due to CROAK() -- can be cleaned */
        int membuf_ro;          /* true means membuf is read-only and msaved is rw */
        struct extendable keybuf;       /* for hash key retrieval */
@@ -1204,6 +1205,9 @@ static void clean_store_context(stcxt_t *cxt)
                sv_free((SV *) hook_seen);
        }
 
+       cxt->forgive_me = -1;                   /* Fetched from perl if needed */
+       cxt->canonical = -1;                    /* Idem */
+
        reset_context(cxt);
 }
 
@@ -1249,6 +1253,7 @@ static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
 #ifndef HAS_UTF8_ALL
         cxt->use_bytes = -1;           /* Fetched from perl if needed */
 #endif
+        cxt->accept_future_minor = -1; /* Fetched from perl if needed */
 }
 
 /*
@@ -1290,6 +1295,14 @@ static void clean_retrieve_context(stcxt_t *cxt)
                sv_free((SV *) hseen);          /* optional HV, for backward compat. */
        }
 
+#ifndef HAS_RESTRICTED_HASHES
+        cxt->derestrict = -1;          /* Fetched from perl if needed */
+#endif
+#ifndef HAS_UTF8_ALL
+        cxt->use_bytes = -1;           /* Fetched from perl if needed */
+#endif
+        cxt->accept_future_minor = -1; /* Fetched from perl if needed */
+
        reset_context(cxt);
 }
 
@@ -4891,12 +4904,26 @@ magic_ok:
                        (version_major == STORABLE_BIN_MAJOR &&
                        version_minor > STORABLE_BIN_MINOR)
             ) {
-               TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
-                         STORABLE_BIN_MINOR));
-
+            int croak_now = 1;
+            TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
+                     STORABLE_BIN_MINOR));
+
+            if (version_major == STORABLE_BIN_MAJOR) {
+                TRACEME(("cxt->accept_future_minor is %d",
+                         cxt->accept_future_minor));
+                if (cxt->accept_future_minor < 0)
+                    cxt->accept_future_minor
+                        = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
+                                              TRUE))
+                           ? 1 : 0);
+                if (cxt->accept_future_minor == 1)
+                    croak_now = 0;  /* Don't croak yet.  */
+            }
+            if (croak_now) {
                CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
-                       version_major, version_minor,
-                       STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
+                       version_major, version_minor,
+                       STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
+            }
         }
 
        /*
@@ -5034,7 +5061,19 @@ static SV *retrieve(stcxt_t *cxt, char *cname)
                TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
                SvREFCNT_inc(sv);       /* One more reference to this same sv */
                return sv;                      /* The SV pointer where object was retrieved */
-       }
+       } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) {
+            if (cxt->accept_future_minor < 0)
+                cxt->accept_future_minor
+                    = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
+                                          TRUE))
+                       ? 1 : 0);
+            if (cxt->accept_future_minor == 1) {
+                CROAK(("Storable binary image v%d.%d contains data of type %d. "
+                       "This Storable is v%d.%d and can only handle data types up to %d",
+                       cxt->ver_major, cxt->ver_minor, type,
+                       STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1));
+            }
+        }
 
 first_time:            /* Will disappear when support for old format is dropped */
 

diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t
index be55970..c8edc45 100644 (file)
--- a/ext/Storable/t/malice.t
+++ b/ext/Storable/t/malice.t
@@ -48,7 +48,7 @@ BEGIN {
   # for network order, and 2 tests per byte on the 'pst0' "magic number" only
   # present in files, but not in things store()ed to memory
   $fancy = ($] > 5.007 ? 2 : 0);
-  plan tests => 334 + length($Config{byteorder}) * 4 + $fancy * 8;
+  plan tests => 378 + length($Config{byteorder}) * 4 + $fancy * 8;
 }
 
 use Storable qw (store retrieve freeze thaw nstore nfreeze);
@@ -174,9 +174,17 @@ sub test_things {
   # )
   my $minor4 = $header->{minor} + 4;
   substr ($copy, $file_magic + 1, 1) = chr $minor4;
-  test_corrupt ($copy, $sub,
-                "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
-                "higher minor");
+  {
+    # Now by default newer minor version numbers are not a pain.
+    $clone = &$sub($copy);
+    ok ($@, "", "by default no error on higher minor");
+    test_hash ($clone);
+
+    local $Storable::accept_future_minor = 0;
+    test_corrupt ($copy, $sub,
+                  "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
+                  "higher minor");
+  }
 
   $copy = $contents;
   my $major1 = $header->{major} + 1;
@@ -224,6 +232,29 @@ sub test_things {
   test_corrupt ($copy, $sub,
                 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
                 "bogus tag");
+
+  # Now drop the minor version number
+  substr ($copy, $file_magic + 1, 1) = chr $minor1;
+
+  test_corrupt ($copy, $sub,
+                "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
+                "bogus tag, minor less 1");
+  # Now increase the minor version number
+  substr ($copy, $file_magic + 1, 1) = chr $minor4;
+
+  # local $Storable::DEBUGME = 1;
+  # This is the delayed croak
+  test_corrupt ($copy, $sub,
+                "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$header->{minor} and can only handle data types up to 25/",
+                "bogus tag, minor plus 4");
+  # And check again that this croak is not delayed:
+  {
+    # local $Storable::DEBUGME = 1;
+    local $Storable::accept_future_minor = 0;
+    test_corrupt ($copy, $sub,
+                  "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
+                  "higher minor");
+  }
 }
 
 sub slurp {