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 vars qw($skip); 17 18BEGIN { 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 36eval <<'EOT' unless $skip; 37use Scalar::Util qw(weaken isweak); 38print "1..22\n"; 39 40######################### End of black magic. 41 42$cnt = 0; 43 44sub ok { 45 ++$cnt; 46 if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; } 47 return $_[0]; 48} 49 50$| = 1; 51 52if(1) { 53 54my ($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} 65print "# START:\n"; 66Dump($y); Dump($z); 67 68ok( $y ne "" and $z ne "" ); 69weaken($y); 70 71print "# WEAK:\n"; 72Dump($y); Dump($z); 73 74ok( $y ne "" and $z ne "" ); 75undef($z); 76 77print "# UNDZ:\n"; 78Dump($y); Dump($z); 79 80ok( not (defined($y) and defined($z)) ); 81undef($y); 82 83print "# UNDY:\n"; 84Dump($y); Dump($z); 85 86ok( not (defined($y) and defined($z)) ); 87 88print "# FIN:\n"; 89Dump($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 102print "# CASE 2:\n"; 103 104{ 105 my $x = "foo"; 106 $y = \$x; 107} 108 109ok( $y ne "" ); 110print "# BW: \n"; 111Dump($y); 112weaken($y); 113print "# AW: \n"; 114Dump($y); 115ok( not defined $y ); 116 117print "# 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} 145print "# OUT $flag\n"; 146ok( $flag == 1 ); 147 148print "# AFTER\n"; 149 150undef $flag; 151 152print "# 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} 168ok( $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 180print "# CASE5\n"; 181Dump($y); 182 183weaken($y); 184Dump($y); 185undef($y); 186 187ok( not defined $y); 188ok($z ne ""); 189 190 191# 192# Case 6: test isweakref 193# 194 195$a = 5; 196ok(!isweak($a)); 197$b = \$a; 198ok(!isweak($b)); 199weaken($b); 200ok(isweak($b)); 201$b = \$a; 202ok(!isweak($b)); 203 204$x = {}; 205weaken($x->{Y} = \$a); 206ok(isweak($x->{Y})); 207ok(!isweak($x->{Z})); 208 209# 210# Case 7: test weaken on a read only ref 211# 212 213if ($] < 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} 220else { 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 233package Dest; 234 235sub DESTROY { 236 print "# INCFLAG\n"; 237 ${$_[0]{Flag}} ++; 238} 239EOT 240