1#!./perl
2
3BEGIN {
4    unless (-d 'blib') {
5	chdir 't' if -d 't';
6	@INC = '../lib';
7	require Config; import Config;
8	keys %Config; # Silence warning
9	if ($Config{extensions} !~ /\bList\/Util\b/) {
10	    print "1..0 # Skip: List::Util was not built\n";
11	    exit 0;
12	}
13    }
14}
15
16use Scalar::Util ();
17use Test::More  (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL)
18			? (skip_all => 'weaken requires XS version')
19			: (tests => 22);
20
21if (0) {
22  require Devel::Peek;
23  Devel::Peek->import('Dump');
24}
25else {
26  *Dump = sub {};
27}
28
29Scalar::Util->import(qw(weaken isweak));
30
31if(1) {
32
33my ($y,$z);
34
35#
36# Case 1: two references, one is weakened, the other is then undef'ed.
37#
38
39{
40	my $x = "foo";
41	$y = \$x;
42	$z = \$x;
43}
44print "# START\n";
45Dump($y); Dump($z);
46
47ok( ref($y) and ref($z));
48
49print "# WEAK:\n";
50weaken($y);
51Dump($y); Dump($z);
52
53ok( ref($y) and ref($z));
54
55print "# UNDZ:\n";
56undef($z);
57Dump($y); Dump($z);
58
59ok( not (defined($y) and defined($z)) );
60
61print "# UNDY:\n";
62undef($y);
63Dump($y); Dump($z);
64
65ok( not (defined($y) and defined($z)) );
66
67print "# FIN:\n";
68Dump($y); Dump($z);
69
70
71#
72# Case 2: one reference, which is weakened
73#
74
75print "# CASE 2:\n";
76
77{
78	my $x = "foo";
79	$y = \$x;
80}
81
82ok( ref($y) );
83print "# BW: \n";
84Dump($y);
85weaken($y);
86print "# AW: \n";
87Dump($y);
88ok( not defined $y  );
89
90print "# EXITBLOCK\n";
91}
92
93#
94# Case 3: a circular structure
95#
96
97$flag = 0;
98{
99	my $y = bless {}, Dest;
100	Dump($y);
101	print "# 1: $y\n";
102	$y->{Self} = $y;
103	Dump($y);
104	print "# 2: $y\n";
105	$y->{Flag} = \$flag;
106	print "# 3: $y\n";
107	weaken($y->{Self});
108	print "# WKED\n";
109	ok( ref($y) );
110	print "# VALS: HASH ",$y,"   SELF ",\$y->{Self},"  Y ",\$y,
111		"    FLAG: ",\$y->{Flag},"\n";
112	print "# VPRINT\n";
113}
114print "# OUT $flag\n";
115ok( $flag == 1 );
116
117print "# AFTER\n";
118
119undef $flag;
120
121print "# FLAGU\n";
122
123#
124# Case 4: a more complicated circular structure
125#
126
127$flag = 0;
128{
129	my $y = bless {}, Dest;
130	my $x = bless {}, Dest;
131	$x->{Ref} = $y;
132	$y->{Ref} = $x;
133	$x->{Flag} = \$flag;
134	$y->{Flag} = \$flag;
135	weaken($x->{Ref});
136}
137ok( $flag == 2 );
138
139#
140# Case 5: deleting a weakref before the other one
141#
142
143{
144	my $x = "foo";
145	$y = \$x;
146	$z = \$x;
147}
148
149print "# CASE5\n";
150Dump($y);
151
152weaken($y);
153Dump($y);
154undef($y);
155
156ok( not defined $y);
157ok( ref($z) );
158
159
160#
161# Case 6: test isweakref
162#
163
164$a = 5;
165ok(!isweak($a));
166$b = \$a;
167ok(!isweak($b));
168weaken($b);
169ok(isweak($b));
170$b = \$a;
171ok(!isweak($b));
172
173$x = {};
174weaken($x->{Y} = \$a);
175ok(isweak($x->{Y}));
176ok(!isweak($x->{Z}));
177
178#
179# Case 7: test weaken on a read only ref
180#
181
182SKIP: {
183    # Doesn't work for older perls, see bug [perl #24506]
184    skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
185
186    $a = eval '\"hello"';
187    ok(ref($a)) or print "# didn't get a ref from eval\n";
188    $b = $a;
189    eval{weaken($b)};
190    # we didn't die
191    ok($@ eq "") or print "# died with $@\n";
192    ok(isweak($b));
193    ok($$b eq "hello") or print "# b is '$$b'\n";
194    $a="";
195    ok(not $b) or print "# b didn't go away\n";
196}
197
198package Dest;
199
200sub DESTROY {
201	print "# INCFLAG\n";
202	${$_[0]{Flag}} ++;
203}
204