1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
package t::detect_memory_leaks;
use strict;
use warnings;
use Test::More;
use Test::Deep;
use File::Temp;
use Promise::XS;
SKIP: {
skip 'Windows, XS, fork, and heap allocation don’t get along.', 1 if $^O eq 'MSWin32';
local $Promise::XS::DETECT_MEMORY_LEAKS = 1;
my $deferred = Promise::XS::deferred();
my $ar = [ $deferred ];
push @$ar, $ar;
my $fh = File::Temp::tempfile();
my $pid = fork or do {
close STDERR;
open *STDERR, '>>&=', $fh;
exit;
};
waitpid $pid, 0;
is(
(stat $fh)[7],
0,
'no warning on leak from subprocess',
) or do {
sysseek $fh, 0, 0;
my $buf = q<>;
1 while sysread( $fh, $buf, 512, length $buf );
diag $buf;
};
@$ar = ();
}
#----------------------------------------------------------------------
{
my @inc_args = map { ( '-I', $_ ) } @INC;
use File::Spec;
my ($dir) = File::Spec->splitdir( __FILE__ );
my $script_path = File::Spec->join( $dir, 'assets', 'deferred_leak.pl' );
my $got = `"$^X" @inc_args -Mstrict -Mwarnings -MPromise::XS $script_path`;
warn "CHILD_ERROR: $?" if $?;
cmp_deeply(
$got,
all(
re( qr<Promise::XS::Deferred=> ),
re( qr<destr>i ),
),
'warning about deferred object that persists to global destruction',
);
}
#----------------------------------------------------------------------
{
my @inc_args = map { ( '-I', $_ ) } @INC;
use File::Spec;
my ($dir) = File::Spec->splitdir( __FILE__ );
my $script_path = File::Spec->join( $dir, 'assets', 'promise_leak.pl' );
my $got = `$^X @inc_args -Mstrict -Mwarnings -MPromise::XS $script_path`;
warn "CHILD_ERROR: $?" if $?;
cmp_deeply(
$got,
all(
re( qr<Promise::XS::Promise=> ),
re( qr<destr>i ),
),
'warning about promise object that persists to global destruction',
);
}
done_testing;
1;
|
