ext/List-Util/t/weak.t

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