This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Scalar-List-Utils-1.15
[perl5.git] / ext / List / Util / t / weak.t
1 #!./perl
2
3 BEGIN {
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
16 use Scalar::Util ();
17 use Test::More  (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL)
18                         ? (skip_all => 'weaken requires XS version')
19                         : (tests => 22);
20
21 if (0) {
22   require Devel::Peek;
23   Devel::Peek->import('Dump');
24 }
25 else {
26   *Dump = sub {};
27 }
28
29 Scalar::Util->import(qw(weaken isweak));
30
31 if(1) {
32
33 my ($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 }
44 print "# START\n";
45 Dump($y); Dump($z);
46
47 ok( ref($y) and ref($z));
48
49 print "# WEAK:\n";
50 weaken($y);
51 Dump($y); Dump($z);
52
53 ok( ref($y) and ref($z));
54
55 print "# UNDZ:\n";
56 undef($z);
57 Dump($y); Dump($z);
58
59 ok( not (defined($y) and defined($z)) );
60
61 print "# UNDY:\n";
62 undef($y);
63 Dump($y); Dump($z);
64
65 ok( not (defined($y) and defined($z)) );
66
67 print "# FIN:\n";
68 Dump($y); Dump($z);
69
70
71
72 # Case 2: one reference, which is weakened
73 #
74
75 print "# CASE 2:\n";
76
77 {
78         my $x = "foo";
79         $y = \$x;
80 }
81
82 ok( ref($y) );
83 print "# BW: \n";
84 Dump($y);
85 weaken($y);
86 print "# AW: \n";
87 Dump($y);
88 ok( not defined $y  );
89
90 print "# 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 }
114 print "# OUT $flag\n";
115 ok( $flag == 1 );
116
117 print "# AFTER\n";
118
119 undef $flag;
120
121 print "# 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 }
137 ok( $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
149 print "# CASE5\n";
150 Dump($y);
151
152 weaken($y);
153 Dump($y);
154 undef($y);
155
156 ok( not defined $y);
157 ok( ref($z) );
158
159
160 #
161 # Case 6: test isweakref
162 #
163
164 $a = 5;
165 ok(!isweak($a));
166 $b = \$a;
167 ok(!isweak($b));
168 weaken($b);
169 ok(isweak($b));
170 $b = \$a;
171 ok(!isweak($b));
172
173 $x = {};
174 weaken($x->{Y} = \$a);
175 ok(isweak($x->{Y}));
176 ok(!isweak($x->{Z}));
177
178 #
179 # Case 7: test weaken on a read only ref
180 #
181
182 SKIP: {
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
198 package Dest;
199
200 sub DESTROY {
201         print "# INCFLAG\n";
202         ${$_[0]{Flag}} ++;
203 }