typedef unsigned long stag_t; /* Used by pre-0.6 binary format */
/*
+ * Make the tag type 64-bit on 64-bit platforms.
+ *
+ * If the tag number is low enough it's stored as a 32-bit value, but
+ * with very large arrays and hashes it's possible to go over 2**32
+ * scalars.
+ */
+
+typedef STRLEN ntag_t;
+
+/*
* The following "thread-safe" related defines were contributed by
* Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
* only renamed things a little bit to ensure consistency with surrounding
#endif
/*
+ * PTR2TAG(x)
+ *
+ * Convert a pointer into an ntag_t.
+ */
+
+#define PTR2TAG(x) ((ntag_t)(x))
+
+#define TAG2PTR(x, type) ((y)(x))
+
+/*
* oI, oS, oC
*
* Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
#endif
if (svh) {
- I32 tagval;
-
- if (sv == &PL_sv_undef) {
+ ntag_t tagval;
+ if (sv == &PL_sv_undef) {
/* We have seen PL_sv_undef before, but fake it as
if we have not.
}
#ifdef USE_PTR_TABLE
- tagval = htonl(LOW_32BITS(((char *)svh)-1));
+ tagval = PTR2TAG(((char *)svh)-1);
#else
- tagval = htonl(LOW_32BITS(*svh));
+ tagval = PTR2TAG(*svh);
#endif
+#ifdef HAS_U64
+
+ /* older versions of Storable streat the tag as a signed value
+ used in an array lookup, corrupting the data structure.
+ Ensure only a newer Storable will be able to parse this tag id
+ if it's over the 2G mark.
+ */
+ if (tagval > I32_MAX) {
- TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv),
- ntohl(tagval)));
+ TRACEME(("object 0x%" UVxf " seen as #%" UVdf, PTR2UV(sv),
+ tagval));
- PUTMARK(SX_OBJECT);
- WRITE_I32(tagval);
- return 0;
+ PUTMARK(SX_LOBJECT);
+ PUTMARK(SX_OBJECT);
+ W64LEN(tagval);
+ return 0;
+ }
+ else
+#endif
+ {
+ I32 ltagval;
+
+ ltagval = htonl((I32)tagval)
+
+ TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv),
+ ntohl(ltagval)));
+
+ PUTMARK(SX_OBJECT);
+ WRITE_I32(ltagval);
+ return 0;
+ }
}
/*
#endif
TRACEME(("wlen %" UVuf, len));
switch (type) {
+ case SX_OBJECT:
+ {
+ /* not a large object, just a large index */
+ SV **svh = av_fetch(cxt->aseen, len, FALSE);
+ if (!svh)
+ CROAK(("Object #%" UVuf " should have been retrieved already",
+ len));
+ sv = *svh;
+ TRACEME(("had retrieved #%" UVuf " at 0x%" UVxf, len, PTR2UV(sv)));
+ SvREFCNT_inc(sv);
+ }
+ break;
case SX_LSCALAR:
sv = get_lstring(aTHX_ cxt, len, 0, cname);
break;
I32 tag;
READ_I32(tag);
tag = ntohl(tag);
- svh = av_fetch(cxt->aseen, tag, FALSE);
+#ifndef HAS_U64
+ /* A 32-bit system can't have over 2**31 objects anyway */
+ if (tag < 0)
+ CROAK(("Object #%" IVdf " out of range", (IV)tag);
+#endif
+ /* Older versions of Storable on with 64-bit support on 64-bit
+ systems can produce values above the 2G boundary (or wrapped above
+ the 4G boundary, which we can't do much about), treat those as
+ unsigned.
+ This same commit stores tag ids over the 2G boundary as long tags
+ since older Storables will mis-handle them as short tags.
+ */
+ svh = av_fetch(cxt->aseen, (U32)tag, FALSE);
if (!svh)
CROAK(("Object #%" IVdf " should have been retrieved already",
(IV) tag));
--- /dev/null
+#!./perl
+
+# We do all of the work in child processes here to ensure that any
+# memory used is released immediately.
+
+# These tests use ridiculous amounts of memory and CPU.
+
+use strict;
+use warnings;
+
+use Config;
+use Storable qw(store_fd retrieve_fd);
+use Test::More;
+use File::Temp qw(tempfile);
+use Devel::Peek;
+
+BEGIN {
+ plan skip_all => 'Storable was not built'
+ if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x;
+ plan skip_all => 'Need 64-bit pointers for this test'
+ if $Config{ptrsize} < 8 and $] > 5.013;
+ plan skip_all => 'Need 64-bit int for this test on older versions'
+ if $Config{uvsize} < 8 and $] < 5.013;
+ plan skip_all => 'Need ~34 GiB memory for this test, set PERL_TEST_MEMORY >= 34'
+ if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 34;
+ plan skip_all => 'These tests are slow, set PERL_RUN_SLOW_TESTS'
+ unless $ENV{PERL_RUN_SLOW_TESTS};
+ plan skip_all => "Need fork for this test",
+ unless $Config{d_fork};
+}
+
+plan tests => 4;
+
+my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} || '';
+
+SKIP:
+{
+ # test object ids between the 2G and 4G marks
+
+ # We now output these as 64-bit ids since older Storables treat
+ # the object id incorrectly and product an incorrect output
+ # structure.
+ #
+ # This uses a lot of memory, we use child processes to ensure the
+ # memory is freed
+ $ENV{PERL_TEST_MEMORY} >= 34
+ or skip "Not enough memory to test 2G-4G object ids", 2;
+ $skips =~ /\b2g\b/
+ and skip "You requested this test be skipped", 2;
+ # IPC::Run would be handy here
+ my $stored;
+ if (defined(my $pid = open(my $fh, "-|"))) {
+ unless ($pid) {
+ # child
+ open my $cfh, "|-", "gzip"
+ or die "Cannot pipe to gzip: $!";
+ binmode $cfh;
+ make_2g_data($cfh);
+ exit;
+ }
+ # parent
+ $stored = do { local $/; <$fh> };
+ close $fh;
+ }
+ else {
+ skip "Cannot fork", 2;
+ }
+ ok($stored, "we got 2G+ id output data");
+ my ($tfh, $tname) = tempfile();
+ print $tfh $stored;
+ close $tfh;
+
+ if (defined(my $pid = open(my $fh, "-|"))) {
+ unless ($pid) {
+ # child
+ open my $bfh, "-|", "gunzip <$tname"
+ or die "Cannot pipe from gunzip: $!";
+ binmode $bfh;
+ check_2g_data($bfh);
+ exit;
+ }
+ my $out = do { local $/; <$fh> };
+ chomp $out;
+ is($out, "OK", "check 2G+ id result");
+ }
+ else {
+ skip "Cannot fork", 1;
+ }
+}
+
+SKIP:
+{
+ # test object ids over 4G
+
+ $ENV{PERL_TEST_MEMORY} >= 70
+ or skip "Not enough memory to test 2G-4G object ids", 2;
+ $skips =~ /\b4g\b/
+ and skip "You requested this test be skipped", 2;
+ # IPC::Run would be handy here
+ my $stored;
+ if (defined(my $pid = open(my $fh, "-|"))) {
+ unless ($pid) {
+ # child
+ open my $cfh, "|-", "gzip"
+ or die "Cannot pipe to gzip: $!";
+ binmode $cfh;
+ make_4g_data($cfh);
+ exit;
+ }
+ # parent
+ $stored = do { local $/; <$fh> };
+ close $fh;
+ }
+ else {
+ skip "Cannot fork", 2;
+ }
+ ok($stored, "we got 4G+ id output data");
+ my ($tfh, $tname) = tempfile();
+ print $tfh $stored;
+ close $tfh;
+
+ if (defined(my $pid = open(my $fh, "-|"))) {
+ unless ($pid) {
+ # child
+ open my $bfh, "-|", "gunzip <$tname"
+ or die "Cannot pipe from gunzip: $!";
+ binmode $bfh;
+ check_4g_data($bfh);
+ exit;
+ }
+ my $out = do { local $/; <$fh> };
+ chomp $out;
+ is($out, "OK", "check 4G+ id result");
+ }
+ else {
+ skip "Cannot fork", 1;
+ }
+}
+
+
+
+sub make_2g_data {
+ my ($fh) = @_;
+ my @x;
+ my $y = 1;
+ my $z = 2;
+ my $g2 = 0x80000000;
+ $x[0] = \$y;
+ $x[$g2] = \$y;
+ $x[$g2+1] = \$z;
+ $x[$g2+2] = \$z;
+ store_fd(\@x, $fh);
+}
+
+sub check_2g_data {
+ my ($fh) = @_;
+ my $x = retrieve_fd($fh);
+ my $g2 = 0x80000000;
+ $x->[0] == $x->[$g2]
+ or die "First entry mismatch";
+ $x->[$g2+1] == $x->[$g2+2]
+ or die "2G+ entry mismatch";
+ print "OK";
+}
+
+sub make_4g_data {
+ my ($fh) = @_;
+ my @x;
+ my $y = 1;
+ my $z = 2;
+ my $g4 = 2*0x80000000;
+ $x[0] = \$y;
+ $x[$g4] = \$y;
+ $x[$g4+1] = \$z;
+ $x[$g4+2] = \$z;
+ store_fd(\@x, $fh);
+}
+
+sub check_4g_data {
+ my ($fh) = @_;
+ my $x = retrieve_fd($fh);
+ my $g4 = 2*0x80000000;
+ $x->[0] == $x->[$g4]
+ or die "First entry mismatch";
+ $x->[$g4+1] == $x->[$g4+2]
+ or die "4G+ entry mismatch";
+ print "OK";
+}
https://perl5.git.perl.org / perl5.git / commitdiff