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 }