From fe1a27444c2dc30d49f7407163a6b037f920e2be Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 13 Apr 2016 08:07:58 +0200
Subject: (perl #127743) simple stupid: prevent storing very large strings

The length of a very large string overflows the 32-bit length stored
in the output.
---
 dist/Storable/Storable.pm | 2 +-
 dist/Storable/Storable.xs | 5 +++++
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/dist/Storable/Storable.pm b/dist/Storable/Storable.pm
index c8f6db1..e928401 100644
--- a/dist/Storable/Storable.pm
+++ b/dist/Storable/Storable.pm
@@ -22,7 +22,7 @@ package Storable; @ISA = qw(Exporter);
 
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.56';
+$VERSION = '2.57';
 
 BEGIN {
     if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 83cd001..49e425a 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -2242,6 +2242,11 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
                              len, SX_VSTRING, SX_LVSTRING);
             }
 #endif
+#if Size_t_size > 4
+            if (len > I32_MAX) {
+                CROAK(("String too long for Storable"));
+            }
+#endif
 
             wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
             if (SvUTF8 (sv))
-- 
2.1.4

From f0ca707438b56331b963a0cbcd1e7d1ba053a969 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 18 Apr 2016 06:52:28 +0200
Subject: (perl #127743) handle 2GB+ scalars on 64-bit platforms

---
 MANIFEST                  |   1 +
 dist/Storable/Storable.xs | 143 +++++++++++++++++++++++++++++++++++++++++-----
 dist/Storable/t/large.t   |  68 ++++++++++++++++++++++
 dist/Storable/t/malice.t  |   4 +-
 4 files changed, 200 insertions(+), 16 deletions(-)
 create mode 100644 dist/Storable/t/large.t

diff --git a/MANIFEST b/MANIFEST
index 3da3119..589194b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3381,6 +3381,7 @@ dist/Storable/t/HAS_OVERLOAD.pm		For auto-requiring of mdoules for overload
 dist/Storable/t/integer.t		See if Storable works
 dist/Storable/t/interwork56.t		Test compatibility kludge for 64bit data under 5.6.x
 dist/Storable/t/just_plain_nasty.t	See if Storable works
+dist/Storable/t/large.t			See if Storable handles large scalars.
 dist/Storable/t/leaks.t			See if Storable leaks (skips in core)
 dist/Storable/t/lock.t			See if Storable works
 dist/Storable/t/make_56_interwork.pl	Make test data for interwork56.t
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 49e425a..802fcf9 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -46,6 +46,10 @@
 #endif	/* PERLIO_IS_STDIO */
 #endif	/* USE_PERLIO */
 
+#ifndef SSize_t_MAX
+#define SSize_t_MAX (SSize_t)(~(Size_t)0 >> 1)
+#endif
+
 /*
  * Earlier versions of perl might be used, we can't assume they have the latest!
  */
@@ -157,7 +161,9 @@
 #define SX_VSTRING	C(29)	/* vstring forthcoming (small) */
 #define SX_LVSTRING	C(30)	/* vstring forthcoming (large) */
 #define SX_SVUNDEF_ELEM	C(31)	/* array element set to &PL_sv_undef */
-#define SX_ERROR	C(32)	/* Error */
+#define SX_VLSCALAR	C(32)	/* scalar longer than I32_MAX */
+#define SX_VLUTF8STR	C(33)	/* UTF-8 string longer than I32_MAX */
+#define SX_ERROR	C(34)	/* Error */
 
 /*
  * Those are only used to retrieve "old" pre-0.6 binary images.
@@ -527,11 +533,11 @@ static stcxt_t *Context_ptr = NULL;
 #define MMASK	(MGROW - 1)
 
 #define round_mgrow(x)	\
-	((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK))
+	((Size_t) (((Size_t) (x) + MMASK) & ~MMASK))
 #define trunc_int(x)	\
-	((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1)))
+	((Size_t) ((Size_t) (x) & ~(sizeof(int)-1)))
 #define int_aligned(x)	\
-	((unsigned long) (x) == trunc_int(x))
+	((Size_t) (x) == trunc_int(x))
 
 #define MBUF_INIT(x)					\
   STMT_START {							\
@@ -590,8 +596,8 @@ static stcxt_t *Context_ptr = NULL;
 
 #define MBUF_XTEND(x) 				\
   STMT_START {						\
-	int nsz = (int) round_mgrow((x)+msiz);	\
-	int offset = mptr - mbase;		\
+	STRLEN nsz = round_mgrow((x)+msiz);	\
+	STRLEN offset = mptr - mbase;		\
 	ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
 	TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
 		msiz, nsz, (x)));			\
@@ -1236,6 +1242,8 @@ static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname);
 static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_vlscalar(pTHX_ stcxt_t *cxt, const char *cname);
+static SV *retrieve_vlutf8str(pTHX_ stcxt_t *cxt, const char *cname);
 
 static const sv_retrieve_t sv_retrieve[] = {
 	0,			/* SX_OBJECT -- entry unused dynamically */
@@ -1270,6 +1278,8 @@ static const sv_retrieve_t sv_retrieve[] = {
 	(sv_retrieve_t)retrieve_vstring,	/* SX_VSTRING */
 	(sv_retrieve_t)retrieve_lvstring,	/* SX_LVSTRING */
 	(sv_retrieve_t)retrieve_svundef_elem,	/* SX_SVUNDEF_ELEM */
+	(sv_retrieve_t)retrieve_vlscalar,	/* SX_VLSCALAR */
+	(sv_retrieve_t)retrieve_vlutf8str,	/* SX_VLUTF8STR */
 	(sv_retrieve_t)retrieve_other,		/* SX_ERROR */
 };
 
@@ -2222,8 +2232,6 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
 #ifdef SvVOK
 	    MAGIC *mg;
 #endif
-            I32 wlen; /* For 64-bit machines */
-
           string_readlen:
             pv = SvPV(sv, len);
 
@@ -2244,15 +2252,30 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
 #endif
 #if Size_t_size > 4
             if (len > I32_MAX) {
-                CROAK(("String too long for Storable"));
+                STRLEN wlen = len;
+                unsigned char smark = SvUTF8(sv) ? SX_VLUTF8STR : SX_VLSCALAR;
+
+                PUTMARK(smark);
+                if (cxt->netorder && BYTEORDER == 0x87654321) {
+                    ((U32*)wlen)[0] = htonl(len >> 32);
+                    ((U32*)wlen)[1] = htonl(len & 0xffffffff);
+                }
+                else {
+                    wlen = len;
+                }
+                WRITE(&wlen, sizeof(wlen));
+                WRITE(pv, len);
             }
+            else
 #endif
 
-            wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
-            if (SvUTF8 (sv))
-                STORE_UTF8STR(pv, wlen);
-            else
-                STORE_SCALAR(pv, wlen);
+            {
+                I32 wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
+                if (SvUTF8 (sv))
+                    STORE_UTF8STR(pv, wlen);
+                else
+                    STORE_SCALAR(pv, wlen);
+            }
             TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
                      PTR2UV(sv), SvPVX(sv), (IV)len));
 	} else
@@ -4990,6 +5013,69 @@ static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname)
 }
 
 /*
+ * retrieve_lscalar
+ *
+ * Retrieve defined long (string) scalar.
+ *
+ * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read.
+ * The scalar is "long" in that <length> is larger than LG_SCALAR so it
+ * was not stored on a single byte.
+ */
+static SV *retrieve_vlscalar(pTHX_ stcxt_t *cxt, const char *cname)
+{
+#if Size_t_size > 4
+	STRLEN len;
+	SV *sv;
+	HV *stash;
+
+        ASSERT(Size_t_size == 8, ("Size_t isn't 8 bytes, code needs re-work"));
+        if (cxt->netorder && BYTEORDER == 0x87654321) {
+            STRLEN rlen;
+            READ(&rlen, sizeof(rlen));
+            len = ((STRLEN)((U32*)&rlen)[0] << 32) | ((U32*)&rlen)[1];
+        }
+        else {
+            READ(&len, sizeof(len));
+        }
+	TRACEME(("retrieve_vlscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len));
+        if (len < I32_MAX || len > SSize_t_MAX) {
+            CROAK(("Size of very large scalar out of range"));
+        }
+
+	/*
+	 * Allocate an empty scalar of the suitable length.
+	 */
+
+	sv = NEWSV(10002, len);
+	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+	SEEN_NN(sv, stash, 0);	/* Associate this new scalar with tag "tagnum" */
+
+	/*
+	 * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
+	 *
+	 * Now, for efficiency reasons, read data directly inside the SV buffer,
+	 * and perform the SV final settings directly by duplicating the final
+	 * work done by sv_setpv. Since we're going to allocate lots of scalars
+	 * this way, it's worth the hassle and risk.
+	 */
+
+	SAFEREAD(SvPVX(sv), len, sv);
+	SvCUR_set(sv, len);				/* Record C string length */
+	*SvEND(sv) = '\0';				/* Ensure it's null terminated anyway */
+	(void) SvPOK_only(sv);			/* Validate string pointer */
+	if (cxt->s_tainted)				/* Is input source tainted? */
+		SvTAINT(sv);				/* External data cannot be trusted */
+
+	TRACEME(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv)));
+	TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
+
+	return sv;
+#else
+        CROAK(("Reading a 2GB or larger string on a 32-bit platform"))'
+#endif
+}
+
+/*
  * retrieve_utf8str
  *
  * Like retrieve_scalar(), but tag result as utf8.
@@ -5047,6 +5133,35 @@ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname)
 }
 
 /*
+ * retrieve_vlutf8str
+ *
+ * Like retrieve_vlscalar(), but tag result as utf8.
+ * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
+ */
+static SV *retrieve_vlutf8str(pTHX_ stcxt_t *cxt, const char *cname)
+{
+    SV *sv;
+
+    TRACEME(("retrieve_vlutf8str"));
+
+    sv = retrieve_vlscalar(aTHX_ cxt, cname);
+    if (sv) {
+#ifdef HAS_UTF8_SCALARS
+        SvUTF8_on(sv);
+#else
+        if (cxt->use_bytes < 0)
+            cxt->use_bytes
+                = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
+                   ? 1 : 0);
+        if (cxt->use_bytes == 0)
+            UTF8_CROAK();
+#endif
+    }
+
+    return sv;
+}
+
+/*
  * retrieve_vstring
  *
  * Retrieve a vstring, and then retrieve the stringy scalar following it,
diff --git a/dist/Storable/t/large.t b/dist/Storable/t/large.t
new file mode 100644
index 0000000..f9b2055
--- /dev/null
+++ b/dist/Storable/t/large.t
@@ -0,0 +1,68 @@
+#!./perl -w
+
+BEGIN {
+    unshift @INC, 't';
+    unshift @INC, 't/compat' if $] < 5.006002;
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+    require 'st-dump.pl';
+}
+
+use Storable qw(freeze thaw nfreeze thaw);
+
+use Test::More;
+
+# memory usage checked with top
+$ENV{PERL_TEST_MEMORY} && $ENV{PERL_TEST_MEMORY} >= 8
+    or plan skip_all => "Need 8GB for this test";
+$Config{ptrsize} >= 8
+    or plan skip_all => "Need 64-bit pointers for this test";
+
+plan tests => 4;
+
+# we might have a lot of RAM, but maybe not so much disk space, so we
+# can only test freeze()/thaw().
+
+my $x = "x"; # avoid constant folding the large x op
+my $data = [ $x x 0x88000000 ]; # 2GB RAM (and a wee bit)
+
+{
+    my $frozen = freeze($data); # another 2GB RAM
+    my $thawed = thaw($frozen); # another 2GB RAM
+    # and add a bit more in case the following 
+    is_deeply($thawed, $data,
+              "check in and out match");
+    undef $frozen;
+    undef $thawed;
+}
+
+{
+    my $frozen = nfreeze($data);
+    my $thawed = thaw($frozen);
+    is_deeply($thawed, $data, "check in and out match (netorder)");
+    undef $frozen;
+    undef $thawed;
+}
+
+$x->[0] .= chr(0x100);
+
+{
+    my $frozen = freeze($data);
+    my $thawed = thaw($frozen);
+    is_deeply($thawed, $data,
+              "check in and out match (utf8)");
+    undef $frozen;
+    undef $thawed;
+}
+
+{
+    my $frozen = nfreeze($data);
+    my $thawed = thaw($frozen);
+    is_deeply($thawed, $data, "check in and out match (utf8,netorder)");
+    undef $frozen;
+    undef $thawed;
+}
+
diff --git a/dist/Storable/t/malice.t b/dist/Storable/t/malice.t
index 867a0d7..1358139 100644
--- a/dist/Storable/t/malice.t
+++ b/dist/Storable/t/malice.t
@@ -208,7 +208,7 @@ sub test_things {
     $where = $file_magic + $network_magic;
   }
 
-  # Just the header and a tag 255. As 31 is currently the highest tag, this
+  # Just the header and a tag 255. As 33 is currently the highest tag, this
   # is "unexpected"
   $copy = substr ($contents, 0, $where) . chr 255;
 
@@ -228,7 +228,7 @@ sub test_things {
   # local $Storable::DEBUGME = 1;
   # This is the delayed croak
   test_corrupt ($copy, $sub,
-                "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 31/",
+                "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 33/",
                 "bogus tag, minor plus 4");
   # And check again that this croak is not delayed:
   {
-- 
2.1.4