1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use Test2::API;
7use Test2::Tools::Basic;
8use Test2::API qw(intercept context);
9use Test2::Tools::Compare qw/match subset array event like/;
10
11use Test2::Tools::Refcount;
12
13my $anon = [];
14
15like(
16    intercept {
17        is_refcount($anon, 1, 'anon ARRAY ref');
18    },
19    array {
20        event Ok => { name => 'anon ARRAY ref', pass => 1 };
21    },
22    'anon ARRAY ref succeeds'
23);
24
25like(
26    intercept {
27        is_refcount("hello", 1, 'not ref');
28    },
29    array {
30        event Ok => { name => 'not ref', pass => 0 };
31        event Diag => { message => match qr/Failed test 'not ref'/ };
32        event Diag => { message => "  expected a reference, was not given one" };
33    },
34    'not ref fails',
35);
36
37my $object = bless {}, "Some::Class";
38
39like(
40    intercept {
41        is_refcount($object, 1, 'object');
42    },
43    array {
44        event Ok => { name => 'object', pass => 1 };
45    },
46    'normal object succeeds',
47);
48
49my $newref = $object;
50
51like(
52    intercept {
53        is_refcount($object, 2, 'two refs');
54    },
55    array {
56        event Ok => { name => 'two refs', pass => 1 };
57    },
58    'two refs to object succeeds',
59);
60
61like(
62    intercept {
63        is_refcount($object, 1, 'one ref');
64    },
65    subset {
66        event Ok => { name => 'one ref', pass => 0 };
67        event Diag => { message => match qr/Failed test 'one ref'/ };
68        event Diag => { message => match qr/expected 1 references, found 2/ };
69
70        if (Test2::Tools::Refcount::HAVE_DEVEL_MAT_DUMPER) {
71            event Diag => { message => match qr/SV address is 0x[0-9a-f]+/ };
72            event Diag => { message => match qr/Writing heap dump to \S+/ };
73        }
74    },
75    "two refs to object fails to be 1"
76);
77
78undef $newref;
79
80$object->{self} = $object;
81
82like(
83    intercept {
84        is_refcount($object, 2, 'circular');
85    },
86    array {
87        event Ok => { name => 'circular', pass => 1 };
88    },
89    'circular object succeeds',
90);
91
92undef $object->{self};
93
94my $otherobject = bless { firstobject => $object }, "Other::Class";
95
96like(
97    intercept {
98        is_refcount($object, 2, 'other ref to object');
99    },
100    array {
101        event Ok => { name => 'other ref to object', pass => 1 };
102    },
103    'object with another reference succeeds',
104);
105
106undef $otherobject;
107
108like(
109    intercept {
110        is_refcount($object, 1, 'undefed other ref to object' );
111    },
112    array {
113        event Ok => { name => 'undefed other ref to object', pass => 1 };
114    },
115    'object with another reference undefed succeeds',
116);
117
118END {
119    # Clean up Devel::MAT dumpfile
120    my $pmat = $0;
121    $pmat =~ s/\.t$/-1.pmat/;
122    unlink $pmat if -f $pmat;
123}
124
125done_testing;
126