(perl #127743) support for >= 4GB data from hooks

Though we use this mechanism for >= 2GB.

This emits an SX_LOBJECT op and writes the string length as a 64-bit
value if STORABLE_attach() returns more than 2GB of data.

The boundary is set at 2GB since older versions of Storable handle
sizes between 2GB and 4GB badly, resulting in a memory overwrite.  By
using the alternate op codes an older Storable will reject the data
instead.

We still accept such data that might have been written by an older
Storable.

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 8f91b7a..b1de510 100644 (file)
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -1428,6 +1428,8 @@ static const sv_retrieve_t sv_old_retrieve[] = {
     (sv_retrieve_t)retrieve_other,     /* SX_LOBJECT not supported */
 };
 
+static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large);
+
 static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname);
@@ -3694,7 +3696,11 @@ static int store_hook(
 
         /* [SX_HOOK] <flags> [<extra>] <object>*/
         if (!recursed++) {
-            PUTMARK(SX_HOOK);
+#ifdef HAS_U64
+            if (len2 > INT32_MAX)
+                PUTMARK(SX_LOBJECT);
+#endif
+           PUTMARK(SX_HOOK);
             PUTMARK(flags);
             if (obj_type == SHT_EXTRA)
                 PUTMARK(eflags);
@@ -3810,7 +3816,11 @@ static int store_hook(
 
     /* SX_HOOK <flags> [<extra>] */
     if (!recursed) {
-        PUTMARK(SX_HOOK);
+#ifdef HAS_U64
+        if (len2 > INT32_MAX)
+           PUTMARK(SX_LOBJECT);
+#endif
+       PUTMARK(SX_HOOK);
         PUTMARK(flags);
         if (obj_type == SHT_EXTRA)
             PUTMARK(eflags);
@@ -3836,8 +3846,14 @@ static int store_hook(
     }
 
     /* <len2> <frozen-str> */
+#ifdef HAS_U64
+    if (len2 > INT32_MAX) {
+        W64LEN(len2);
+    }
+    else
+#endif
     if (flags & SHF_LARGE_STRLEN) {
-        I32 wlen2 = len2;              /* STRLEN might be 8 bytes */
+        U32 wlen2 = len2;              /* STRLEN might be 8 bytes */
         WLEN(wlen2);                   /* Must write an I32 for 64-bit machines */
     } else {
         unsigned char clen = (unsigned char) len2;
@@ -4693,13 +4709,13 @@ static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
  * processing (since we won't have seen the magic object by the time the hook
  * is called).  See comments below for why it was done that way.
  */
-static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
+static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large)
 {
     U32 len;
     char buf[LG_BLESS + 1];            /* Avoid malloc() if possible */
     char *classname = buf;
     unsigned int flags;
-    U32 len2;
+    STRLEN len2;
     SV *frozen;
     I32 len3 = 0;
     AV *av = 0;
@@ -4720,6 +4736,11 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
     TRACEME(("retrieve_hook (#%d)", (int)cxt->tagnum));
     ASSERT(!cname, ("no bless-into class given here, got %s", cname));
 
+#ifndef HAS_U64
+    assert(!large);
+    PERL_UNUSED_ARG(large);
+#endif
+
     /*
      * Read flags, which tell us about the type, and whether we need
      * to recurse.
@@ -4868,8 +4889,17 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
      * To understand that code, read retrieve_scalar()
      */
 
-    if (flags & SHF_LARGE_STRLEN)
-        RLEN(len2);
+#ifdef HAS_U64
+    if (large) {
+        READ_U64(len2);
+    }
+    else
+#endif
+    if (flags & SHF_LARGE_STRLEN) {
+        U32 len32;
+        RLEN(len32);
+        len2 = len32;
+    }
     else
         GETMARK(len2);
 
@@ -5156,6 +5186,10 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
     return sv;
 }
 
+static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) {
+    return retrieve_hook_common(aTHX_ cxt, cname, FALSE);
+}
+
 /*
  * retrieve_ref
  *
@@ -5792,6 +5826,9 @@ static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname)
        */
        GETMARK(hash_flags);
     }
+    else if (type == SX_HOOK) {
+        return retrieve_hook_common(aTHX_ cxt, cname, TRUE);
+    }
 
     READ_U64(len);
     TRACEME(("wlen %" UVuf, len));

diff --git a/dist/Storable/t/hugeids.t b/dist/Storable/t/hugeids.t
index 91d31c9..b0c4af0 100644 (file)
--- a/dist/Storable/t/hugeids.t
+++ b/dist/Storable/t/hugeids.t
@@ -29,7 +29,7 @@ BEGIN {
         unless $Config{d_fork};
 }
 
-plan tests => 10;
+plan tests => 12;
 
 my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} || '';
 my $keeps = $ENV{PERL_STORABLE_KEEP_ID_TEST};
@@ -78,6 +78,15 @@ freeze_thaw_test
      freeze => \&make_2g_hook_data,
      thaw => \&check_2g_hook_data,
      id => "hook2gdata",
+     memory => 4,
+    );
+
+freeze_thaw_test
+    (
+     name => "hook store with 4g data",
+     freeze => \&make_4g_hook_data,
+     thaw => \&check_4g_hook_data,
+     id => "hook4gdata",
      memory => 8,
     );
 
@@ -271,6 +280,25 @@ sub check_2g_hook_data {
     print "OK";
 }
 
+sub make_4g_hook_data {
+    my ($fh) = @_;
+
+    my $g2 = 0x80000000;
+    my $g4 = 2 * $g2;
+    my $x = HookLargeData->new($g4+1);
+    store_fd($x, $fh);
+}
+
+sub check_4g_hook_data {
+    my ($fh) = @_;
+    my $x = retrieve_fd($fh);
+    my $g2 = 0x80000000;
+    my $g4 = 2 * $g2;
+    $x->size == $g4+1
+        or die "Size incorrect ", $x->size;
+    print "OK";
+}
+
 package HookLargeIds;
 
 sub new {