This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable: fixup huge
authorReini Urban <rurban@cpanel.net>
Thu, 26 Jan 2017 23:31:35 +0000 (17:31 -0600)
committerTony Cook <tony@develop-help.com>
Thu, 8 Feb 2018 02:34:10 +0000 (13:34 +1100)
followup to 67a5186ac1aee4b63 with 3.00c.
MBUF_XTEND and more internal sizes, esp. the dclone size,
needs to use long, not int.
Improve TRACEME to cut off printing overlong strings.

(cherry picked from commit d987f810b5f285b075103f58ce43e54d181643bc)

Conflicts:
pod/perlcdelta.pod
pod/perlcperl.pod
t/porting/customized.dat

dist/Storable/ChangeLog
dist/Storable/Storable.xs
dist/Storable/t/huge.t

index 11f6eee..2965ebd 100644 (file)
@@ -4,10 +4,13 @@ Wed Jan 25 11:27:07 2017 -0600 Reini Urban <rurban@cpanel.net>
         * Protect against classname len overflow on the stack
         and 2x on the heap with retrieve_bless and retrieve_hook.
         A serious security issue with malcrafted storable files or buffers,
-        but p5p accepts no CVE on Storable attacks. See RT #130635 (detected by JD).
+        but p5p accepts no CVE on Storable attacks. See RT #130635
+        (reported by JD).
         * Fix NULL ptr SEGVs with retrieve_code and retrieve_other.
-        See RT #130098(JD)
-        * Fix the remaining 2-arg open calls
+        See RT #130098 (reported and fixed by JD)
+        * Fix wrong huge LOBJECT support, broken since 3.00c.
+        Repro with `export PERL_TEST_MEMORY=8`
+        * Fix the few remaining 2-arg open calls.
 
 Sat Jan 7 09:01:29 2017 +0100 Reini Urban <rurban@cpanel.net>
     Version 3.04c
index 9a28a76..4ed5f9f 100644 (file)
@@ -610,11 +610,11 @@ 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 = (STRLEN) 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)", \
-                        (int)msiz, nsz, (int)(x)));                    \
+               TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \
+                        (long)msiz, nsz, (long)(x)));                  \
                Renew(mbase, nsz, char);                                \
                msiz = nsz;                                             \
                mptr = mbase + offset;                                  \
@@ -895,6 +895,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 #define STORABLE_BIN_WRITE_MINOR       8
 #elif PATCHLEVEL >= 19
 /* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
+/* With 3.x we added LOBJECT */
 #define STORABLE_BIN_WRITE_MINOR       11
 #else
 #define STORABLE_BIN_WRITE_MINOR       9
@@ -2364,8 +2365,9 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
                        STORE_UTF8STR(pv, wlen);
                else
                        STORE_SCALAR(pv, wlen);
-               TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" IVdf ")",
-                        PTR2UV(sv), SvPVX(sv), (IV)len));
+               TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")",
+                        PTR2UV(sv), len >= 2048 ? "<string too long>" : SvPVX(sv),
+                         (UV)len));
        } else {
                CROAK(("Can't determine type of %s(0x%" UVxf ")",
                       sv_reftype(sv, FALSE),
@@ -5234,7 +5236,8 @@ static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname
         }
 
        if (isutf8) {
-               TRACEME(("large utf8 string len %" UVuf " '%s'", len, SvPVX(sv)));
+               TRACEME(("large utf8 string len %" UVuf " '%s'", len,
+                         len >= 2048 ? "<string too long>" : SvPVX(sv)));
 #ifdef HAS_UTF8_SCALARS
                SvUTF8_on(sv);
 #else
@@ -5246,7 +5249,8 @@ static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname
                        UTF8_CROAK();
 #endif
        } else {
-               TRACEME(("large string len %" UVuf " '%s'", len, SvPVX(sv)));
+               TRACEME(("large string len %" UVuf " '%s'", len,
+                         len >= 2048 ? "<string too long>" : SvPVX(sv)));
        }
        TRACEME(("ok (get_lstring at 0x%" UVxf ")", PTR2UV(sv)));
 
@@ -6408,8 +6412,9 @@ static SV *magic_check(pTHX_ stcxt_t *cxt)
                        current = buf + old_len;
                }
                use_network_order = *current;
-       } else
+       } else {
                GETMARK(use_network_order);
+        }
 
        /*
         * Starting with 0.6, the "use_network_order" byte flag is also used to
@@ -6974,7 +6979,7 @@ static SV *mretrieve(pTHX_ SV *sv, IV flag)
 static SV *dclone(pTHX_ SV *sv)
 {
        dSTCXT;
-       int size;
+       STRLEN size;
        stcxt_t *real_context;
        SV *out;
 
@@ -7028,7 +7033,7 @@ static SV *dclone(pTHX_ SV *sv)
        ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
 
        size = MBUF_SIZE();
-       TRACEME(("dclone stored %d bytes", size));
+       TRACEME(("dclone stored %ld bytes", (long)size));
        MBUF_INIT(size);
 
        /*
index 2511144..a1f7d5e 100644 (file)
@@ -18,17 +18,17 @@ BEGIN {
 
 # Just too big to fit in an I32.
 my $huge = int(2 ** 31);
+#my $veryhuge = int(0x90000000); # go all the way
 
 # These overlarge sizes are enabled only since Storable 3.00 and some
 # cases need cperl support. Perl5 (as of 5.24) has some internal
-# problems with >I32 sizes.
+# problems with >I32 sizes, which only cperl has fixed.
+# hash key size: U32
+
 my @cases = (
     ['huge string',
      sub { my $s = 'x' x $huge; \$s }],
 
-    ['huge array',
-     sub { my @x; $x[$huge] = undef; \@x }],
-
     ['array with huge element',
      sub { my $s = 'x' x $huge; [$s] }],
 
@@ -40,28 +40,40 @@ my @cases = (
 
     # Can't test hash with a huge key, because Perl internals currently
     # limit hash keys to <2**31 length.
+  );
 
-    # Only cperl can handle more than I32 hash keys due to limited iterator size.
+# v5.24.1c/v5.25.1c switched to die earlier with "Too many elements",
+# which is much safer.
+if (!($Config{usecperl} and
+      (($] >= 5.024001 and $] < 5.025000)
+       or $] >= 5.025001))) {
+  push @cases,
+    ['huge array',
+     sub { my @x; $x[$huge] = undef; \@x }],
+    # number of keys
     ['huge hash',
-     sub { my %x = (0..0xffffffff); \%x }],
-);
+     sub { my %x = (0..$huge); \%x } ];
+}
+
 
 plan tests => 2 * scalar @cases;
 
 for (@cases) {
     my ($desc, $build) = @$_;
     note "building test input: $desc";
-    my $input = $build->();
-    note "running test: $desc";
-    my ($exn, $clone);
-    $exn = $@ if !eval { $clone = dclone($input); 1 };
-    if ($Config{usecperl} or $] >= 5.025003) { # guessing
-        is($exn, '');
-        is($input, $clone);
+    my ($input, $exn, $clone);
+    if ($build) {
+      $input = $build->();
+      note "running test: $desc";
+      $exn = $@ if !eval { $clone = dclone($input); 1 };
+    }
+    if ($build && $Config{usecperl}) { # perl5 is not yet 2GB safe.
+        is($exn, undef, "$desc no exception");
+        is_deeply($clone, $input, "$desc cloned");
     } else {
         like($exn, qr/^Storable cannot yet handle data that needs a 64-bit machine\b/,
              "$desc: throw an exception, not a segfault or panic");
-        ok(1, "skip comparison");
+        ok(1, "$desc skip comparison");
     }
 
     # Ensure the huge objects are freed right now: