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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
#!/usr/bin/perl
use strict;
use warnings;
use Test2::API;
use Test2::Tools::Basic;
use Test2::API qw(intercept context);
use Test2::Tools::Compare qw/match subset array event like/;
use Test2::Tools::Refcount;
my $anon = [];
like(
intercept {
is_refcount($anon, 1, 'anon ARRAY ref');
},
array {
event Ok => { name => 'anon ARRAY ref', pass => 1 };
},
'anon ARRAY ref succeeds'
);
like(
intercept {
is_refcount("hello", 1, 'not ref');
},
array {
event Ok => { name => 'not ref', pass => 0 };
event Diag => { message => match qr/Failed test 'not ref'/ };
event Diag => { message => " expected a reference, was not given one" };
},
'not ref fails',
);
my $object = bless {}, "Some::Class";
like(
intercept {
is_refcount($object, 1, 'object');
},
array {
event Ok => { name => 'object', pass => 1 };
},
'normal object succeeds',
);
my $newref = $object;
like(
intercept {
is_refcount($object, 2, 'two refs');
},
array {
event Ok => { name => 'two refs', pass => 1 };
},
'two refs to object succeeds',
);
like(
intercept {
is_refcount($object, 1, 'one ref');
},
subset {
event Ok => { name => 'one ref', pass => 0 };
event Diag => { message => match qr/Failed test 'one ref'/ };
event Diag => { message => match qr/expected 1 references, found 2/ };
if (Test2::Tools::Refcount::HAVE_DEVEL_MAT_DUMPER) {
event Diag => { message => match qr/SV address is 0x[0-9a-f]+/ };
event Diag => { message => match qr/Writing heap dump to \S+/ };
}
},
"two refs to object fails to be 1"
);
undef $newref;
$object->{self} = $object;
like(
intercept {
is_refcount($object, 2, 'circular');
},
array {
event Ok => { name => 'circular', pass => 1 };
},
'circular object succeeds',
);
undef $object->{self};
my $otherobject = bless { firstobject => $object }, "Other::Class";
like(
intercept {
is_refcount($object, 2, 'other ref to object');
},
array {
event Ok => { name => 'other ref to object', pass => 1 };
},
'object with another reference succeeds',
);
undef $otherobject;
like(
intercept {
is_refcount($object, 1, 'undefed other ref to object' );
},
array {
event Ok => { name => 'undefed other ref to object', pass => 1 };
},
'object with another reference undefed succeeds',
);
END {
# Clean up Devel::MAT dumpfile
my $pmat = $0;
$pmat =~ s/\.t$/-1.pmat/;
unlink $pmat if -f $pmat;
}
done_testing;
|
