This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1096e9edee22daf32da5a887e87b91ee610a6bb9
[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 vars qw($skip);
17
18 BEGIN {
19   $|=1;
20   require Scalar::Util;
21   if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
22     print("1..0\n");
23     $skip=1;
24   }
25
26   $DEBUG = 0;
27
28   if ($DEBUG && eval { require Devel::Peek } ) {
29     Devel::Peek->import('Dump');
30   }
31   else {
32     *Dump = sub {};
33   }
34 }
35
36 eval <<'EOT' unless $skip;
37 use Scalar::Util qw(weaken isweak);
38 print "1..22\n";
39
40 ######################### End of black magic.
41
42 $cnt = 0;
43
44 sub ok {
45         ++$cnt;
46         if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
47         return $_[0];
48 }
49
50 $| = 1;
51
52 if(1) {
53
54 my ($y,$z);
55
56 #
57 # Case 1: two references, one is weakened, the other is then undef'ed.
58 #
59
60 {
61         my $x = "foo";
62         $y = \$x;
63         $z = \$x;
64 }
65 print "# START:\n";
66 Dump($y); Dump($z);
67
68 ok( $y ne "" and $z ne "" );
69 weaken($y);
70
71 print "# WEAK:\n";
72 Dump($y); Dump($z);
73
74 ok( $y ne "" and $z ne "" );
75 undef($z);
76
77 print "# UNDZ:\n";
78 Dump($y); Dump($z);
79
80 ok( not (defined($y) and defined($z)) );
81 undef($y);
82
83 print "# UNDY:\n";
84 Dump($y); Dump($z);
85
86 ok( not (defined($y) and defined($z)) );
87
88 print "# FIN:\n";
89 Dump($y); Dump($z);
90
91 # exit(0);
92
93 # }
94 # {
95
96
97 # Case 2: one reference, which is weakened
98 #
99
100 # kill 5,$$;
101
102 print "# CASE 2:\n";
103
104 {
105         my $x = "foo";
106         $y = \$x;
107 }
108
109 ok( $y ne "" );
110 print "# BW: \n";
111 Dump($y);
112 weaken($y);
113 print "# AW: \n";
114 Dump($y);
115 ok( not defined $y  );
116
117 print "# EXITBLOCK\n";
118 }
119
120 # exit(0);
121
122
123 # Case 3: a circular structure
124 #
125
126 # kill 5, $$;
127
128 $flag = 0;
129 {
130         my $y = bless {}, Dest;
131         Dump($y);
132         print "# 1: $y\n";
133         $y->{Self} = $y;
134         Dump($y);
135         print "# 2: $y\n";
136         $y->{Flag} = \$flag;
137         print "# 3: $y\n";
138         weaken($y->{Self});
139         print "# WKED\n";
140         ok( $y ne "" );
141         print "# VALS: HASH ",$y,"   SELF ",\$y->{Self},"  Y ",\$y, 
142                 "    FLAG: ",\$y->{Flag},"\n";
143         print "# VPRINT\n";
144 }
145 print "# OUT $flag\n";
146 ok( $flag == 1 );
147
148 print "# AFTER\n";
149
150 undef $flag;
151
152 print "# FLAGU\n";
153
154 #
155 # Case 4: a more complicated circular structure
156 #
157
158 $flag = 0;
159 {
160         my $y = bless {}, Dest;
161         my $x = bless {}, Dest;
162         $x->{Ref} = $y;
163         $y->{Ref} = $x;
164         $x->{Flag} = \$flag;
165         $y->{Flag} = \$flag;
166         weaken($x->{Ref});
167 }
168 ok( $flag == 2 );
169
170 #
171 # Case 5: deleting a weakref before the other one
172 #
173
174 {
175         my $x = "foo";
176         $y = \$x;
177         $z = \$x;
178 }
179
180 print "# CASE5\n";
181 Dump($y);
182
183 weaken($y);
184 Dump($y);
185 undef($y);
186
187 ok( not defined $y);
188 ok($z ne "");
189
190
191 #
192 # Case 6: test isweakref
193 #
194
195 $a = 5;
196 ok(!isweak($a));
197 $b = \$a;
198 ok(!isweak($b));
199 weaken($b);
200 ok(isweak($b));
201 $b = \$a;
202 ok(!isweak($b));
203
204 $x = {};
205 weaken($x->{Y} = \$a);
206 ok(isweak($x->{Y}));
207 ok(!isweak($x->{Z}));
208
209 #
210 # Case 7: test weaken on a read only ref
211 #
212
213 if ($] < 5.008003) {
214     # Doesn't work for older perls, see bug [perl #24506]
215     print "# Skip next 5 tests on perl $]\n";
216     for (1..5) {
217         ok(1);
218     }
219 }
220 else {
221     $a = eval '\"hello"';
222     ok(ref($a)) or print "# didn't get a ref from eval\n";
223     $b = $a;
224     eval{weaken($b)};
225     # we didn't die
226     ok($@ eq "") or print "# died with $@\n";
227     ok(isweak($b));
228     ok($$b eq "hello") or print "# b is '$$b'\n";
229     $a="";
230     ok(not $b) or print "# b didn't go away\n";
231 }
232
233 package Dest;
234
235 sub DESTROY {
236         print "# INCFLAG\n";
237         ${$_[0]{Flag}} ++;
238 }
239 EOT