1#!./perl
2
3# We do all of the work in child processes here to ensure that any
4# memory used is released immediately.
5
6# These tests use ridiculous amounts of memory and CPU.
7
8use strict;
9use warnings;
10
11use Config;
12use Storable qw(store_fd retrieve_fd nstore_fd);
13use Test::More;
14use File::Temp qw(tempfile);
15use File::Spec;
16
17BEGIN {
18    plan skip_all => 'Storable was not built'
19        if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x;
20    plan skip_all => 'Need 64-bit pointers for this test'
21        if $Config{ptrsize} < 8 and $] > 5.013;
22    plan skip_all => 'Need 64-bit int for this test on older versions'
23        if $Config{uvsize} < 8 and $] < 5.013;
24    plan skip_all => 'Need ~8 GiB memory for this test, set PERL_TEST_MEMORY >= 8'
25        if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 8;
26    plan skip_all => 'These tests are slow, set PERL_RUN_SLOW_TESTS'
27        unless $ENV{PERL_RUN_SLOW_TESTS};
28    plan skip_all => "Need fork for this test",
29        unless $Config{d_fork};
30}
31
32find_exe("gzip")
33    or plan skip_all => "Need gzip for this test";
34find_exe("gunzip")
35    or plan skip_all => "Need gunzip for this test";
36
37plan tests => 12;
38
39my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} || '';
40my $keeps = $ENV{PERL_STORABLE_KEEP_ID_TEST};
41
42freeze_thaw_test
43  (
44   name => "object ids between 2G and 4G",
45   freeze => \&make_2g_data,
46   thaw => \&check_2g_data,
47   id => "2g",
48   memory => 34,
49  );
50
51freeze_thaw_test
52  (
53   name => "object ids over 4G",
54   freeze => \&make_4g_data,
55   thaw => \&check_4g_data,
56   id => "4g",
57   memory => 70,
58  );
59
60freeze_thaw_test
61  (
62   name => "hook object ids over 4G",
63   freeze => \&make_hook_data,
64   thaw => \&check_hook_data,
65   id => "hook4g",
66   memory => 70,
67  );
68
69# not really an id test, but the infrastructure here makes tests
70# easier
71freeze_thaw_test
72  (
73   name => "network store large PV",
74   freeze => \&make_net_large_pv,
75   thaw => \&check_net_large_pv,
76   id => "netlargepv",
77   memory => 8,
78  );
79
80freeze_thaw_test
81    (
82     name => "hook store with 2g data",
83     freeze => \&make_2g_hook_data,
84     thaw => \&check_2g_hook_data,
85     id => "hook2gdata",
86     memory => 4,
87    );
88
89freeze_thaw_test
90    (
91     name => "hook store with 4g data",
92     freeze => \&make_4g_hook_data,
93     thaw => \&check_4g_hook_data,
94     id => "hook4gdata",
95     memory => 8,
96    );
97
98sub freeze_thaw_test {
99    my %opts = @_;
100
101    my $freeze = $opts{freeze}
102      or die "Missing freeze";
103    my $thaw = $opts{thaw}
104      or die "Missing thaw";
105    my $id = $opts{id}
106      or die "Missing id";
107    my $name = $opts{name}
108      or die "Missing name";
109    my $memory = $opts{memory}
110      or die "Missing memory";
111    my $todo_thaw = $opts{todo_thaw} || "";
112
113  SKIP:
114    {
115	# IPC::Run would be handy here
116
117	$ENV{PERL_TEST_MEMORY} >= $memory
118	  or skip "Not enough memory to test $name", 2;
119	$skips =~ /\b\Q$id\E\b/
120	  and skip "You requested test $name ($id) be skipped", 2;
121        defined $keeps && $keeps !~ /\b\Q$id\E\b/
122            and skip "You didn't request test $name ($id)", 2;
123	my $stored;
124	if (defined(my $pid = open(my $fh, "-|"))) {
125	    unless ($pid) {
126		# child
127		open my $cfh, "|-", "gzip"
128		  or die "Cannot pipe to gzip: $!";
129		binmode $cfh;
130		$freeze->($cfh);
131		exit;
132	    }
133	    # parent
134	    $stored = do { local $/; <$fh> };
135	    close $fh;
136	}
137	else {
138	    skip "$name: Cannot fork for freeze", 2;
139	}
140	ok($stored, "$name: we got output data")
141	  or skip "$name: skipping thaw test", 1;
142
143	my ($tfh, $tname) = tempfile();
144
145	#my $tname = "$id.store.gz";
146	#open my $tfh, ">", $tname or die;
147	#binmode $tfh;
148
149	print $tfh $stored;
150	close $tfh;
151    
152	if (defined(my $pid = open(my $fh, "-|"))) {
153	    unless ($pid) {
154		# child
155		open my $bfh, "-|", "gunzip <$tname"
156		  or die "Cannot pipe from gunzip: $!";
157		binmode $bfh;
158		$thaw->($bfh);
159		exit;
160	    }
161	    my $out = do { local $/; <$fh> };
162	    chomp $out;
163	    local $TODO = $todo_thaw;
164	    is($out, "OK", "$name: check result");
165	}
166	else {
167	    skip "$name: Cannot fork for thaw", 1;
168	}
169    }
170}
171
172
173sub make_2g_data {
174  my ($fh) = @_;
175  my @x;
176  my $y = 1;
177  my $z = 2;
178  my $g2 = 0x80000000;
179  $x[0] = \$y;
180  $x[$g2] = \$y;
181  $x[$g2+1] = \$z;
182  $x[$g2+2] = \$z;
183  store_fd(\@x, $fh);
184}
185
186sub check_2g_data {
187  my ($fh) = @_;
188  my $x = retrieve_fd($fh);
189  my $g2 = 0x80000000;
190  $x->[0] == $x->[$g2]
191    or die "First entry mismatch";
192  $x->[$g2+1] == $x->[$g2+2]
193    or die "2G+ entry mismatch";
194  print "OK";
195}
196
197sub make_4g_data {
198  my ($fh) = @_;
199  my @x;
200  my $y = 1;
201  my $z = 2;
202  my $g4 = 2*0x80000000;
203  $x[0] = \$y;
204  $x[$g4] = \$y;
205  $x[$g4+1] = \$z;
206  $x[$g4+2] = \$z;
207  store_fd(\@x, $fh);
208}
209
210sub check_4g_data {
211  my ($fh) = @_;
212  my $x = retrieve_fd($fh);
213  my $g4 = 2*0x80000000;
214  $x->[0] == $x->[$g4]
215    or die "First entry mismatch";
216  $x->[$g4+1] == $x->[$g4+2]
217    or die "4G+ entry mismatch";
218  ${$x->[$g4+1]} == 2
219    or die "Incorrect value in 4G+ entry";
220  print "OK";
221}
222
223sub make_hook_data {
224    my ($fh) = @_;
225    my @x;
226    my $y = HookLargeIds->new(101, { name => "one" });
227    my $z = HookLargeIds->new(201, { name => "two" });
228    my $g4 = 2*0x8000_0000;
229    $x[0] = $y;
230    $x[$g4] = $y;
231    $x[$g4+1] = $z;
232    $x[$g4+2] = $z;
233    store_fd(\@x, $fh);
234}
235
236sub check_hook_data {
237    my ($fh) = @_;
238    my $x = retrieve_fd($fh);
239    my $g4 = 2*0x8000_0000;
240    my $y = $x->[$g4+1];
241    $y = $x->[$g4+1];
242    $y->id == 201
243      or die "Incorrect id in 4G+ object";
244    ref($y->data) eq 'HASH'
245      or die "data isn't a ref";
246    $y->data->{name} eq "two"
247      or die "data name not 'one'";
248    print "OK";
249}
250
251sub make_net_large_pv {
252    my ($fh) = @_;
253    my $x = "x"; # avoid constant folding making a 4G scalar
254    my $g4 = 2*0x80000000;
255    my $y = $x x ($g4 + 5);
256    nstore_fd(\$y, $fh);
257}
258
259sub check_net_large_pv {
260    my ($fh) = @_;
261    my $x = retrieve_fd($fh);
262    my $g4 = 2*0x80000000;
263    ref $x && ref($x) eq "SCALAR"
264      or die "Not a scalar ref ", ref $x;
265
266    length($$x) == $g4+5
267      or die "Incorect length";
268    print "OK";
269}
270
271sub make_2g_hook_data {
272    my ($fh) = @_;
273
274    my $g2 = 0x80000000;
275    my $x = HookLargeData->new($g2);
276    store_fd($x, $fh);
277}
278
279sub check_2g_hook_data {
280    my ($fh) = @_;
281    my $x = retrieve_fd($fh);
282    my $g2 = 0x80000000;
283    $x->size == $g2
284        or die "Size incorrect ", $x->size;
285    print "OK";
286}
287
288sub make_4g_hook_data {
289    my ($fh) = @_;
290
291    my $g2 = 0x80000000;
292    my $g4 = 2 * $g2;
293    my $x = HookLargeData->new($g4+1);
294    store_fd($x, $fh);
295}
296
297sub check_4g_hook_data {
298    my ($fh) = @_;
299    my $x = retrieve_fd($fh);
300    my $g2 = 0x80000000;
301    my $g4 = 2 * $g2;
302    $x->size == $g4+1
303        or die "Size incorrect ", $x->size;
304    print "OK";
305}
306
307sub find_exe {
308    my ($exe) = @_;
309
310    $exe .= $Config{_exe};
311    my @path = split /\Q$Config{path_sep}/, $ENV{PATH};
312    for my $dir (@path) {
313        my $abs = File::Spec->catfile($dir, $exe);
314        -x $abs
315            and return $abs;
316    }
317}
318
319package HookLargeIds;
320
321sub new {
322    my $class = shift;
323    my ($id, $data) = @_;
324    return bless { id => $id, data => $data }, $class;
325}
326
327sub STORABLE_freeze {
328    #print STDERR "freeze called\n";
329    #Devel::Peek::Dump($_[0]);
330
331    return $_[0]->id, $_[0]->data;
332}
333
334sub STORABLE_thaw {
335    my ($self, $cloning, $ser, $data) = @_;
336
337    #Devel::Peek::Dump(\@_);
338    #print STDERR "thaw called\n";
339    #Devel::Peek::Dump($self);
340    $self->{id} = $ser+0;
341    $self->{data} = $data;
342}
343
344sub id {
345    $_[0]{id};
346}
347
348sub data {
349    $_[0]{data};
350}
351
352package HookLargeData;
353
354sub new {
355    my ($class, $size) = @_;
356
357    return bless { size => $size }, $class;
358}
359
360sub STORABLE_freeze {
361    return "x" x $_[0]{size};
362}
363
364sub STORABLE_thaw {
365    my ($self, $cloning, $ser) = @_;
366
367    $self->{size} = length $ser;
368}
369
370sub size {
371    $_[0]{size};
372}
373