This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Scalar-List-Utils to CPAN version 1.37
[perl5.git] / cpan / Scalar-List-Utils / t / weak.t
CommitLineData
1bfb5477
GB
1#!./perl
2
2ff28616
GB
3use strict;
4use Config;
f4a2945e 5BEGIN {
1bfb5477 6 unless (-d 'blib') {
f4a2945e
JH
7 chdir 't' if -d 't';
8 @INC = '../lib';
1bfb5477 9 keys %Config; # Silence warning
6b05f64e
PP
10 if ($Config{extensions} !~ /\bList\/Util\b/) {
11 print "1..0 # Skip: List::Util was not built\n";
12 exit 0;
13 }
1bfb5477 14 }
f4a2945e
JH
15}
16
cf083cf9 17use Scalar::Util ();
2ff28616 18use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE})
cf083cf9 19 ? (skip_all => 'weaken requires XS version')
568d025d 20 : (tests => 28);
cf083cf9 21
8c167fd9 22Scalar::Util->import(qw(weaken unweaken isweak));
f4a2945e 23
8c167fd9 24# two references, one is weakened, the other is then undef'ed.
f4a2945e 25{
8c167fd9 26 my ($y,$z);
f4a2945e 27
8c167fd9
CBW
28 {
29 my $x = "foo";
30 $y = \$x;
31 $z = \$x;
32 }
f4a2945e 33
8c167fd9 34 ok(ref($y) and ref($z));
f4a2945e 35
8c167fd9
CBW
36 weaken($y);
37 ok(ref($y) and ref($z));
f4a2945e 38
8c167fd9
CBW
39 undef($z);
40 ok(not(defined($y) and defined($z)));
f4a2945e 41
8c167fd9
CBW
42 undef($y);
43 ok(not(defined($y) and defined($z)));
44}
f4a2945e 45
8c167fd9
CBW
46# one reference, which is weakened
47{
48 my $y;
f4a2945e 49
8c167fd9
CBW
50 {
51 my $x = "foo";
52 $y = \$x;
53 }
f4a2945e 54
8c167fd9 55 ok(ref($y));
f4a2945e 56
8c167fd9
CBW
57 weaken($y);
58 ok(not defined $y);
59}
f4a2945e 60
8c167fd9 61my $flag;
f4a2945e 62
8c167fd9 63# a circular structure
f4a2945e 64{
8c167fd9 65 $flag = 0;
f4a2945e 66
8c167fd9
CBW
67 {
68 my $y = bless {}, 'Dest';
69 $y->{Self} = $y;
70 $y->{Flag} = \$flag;
f4a2945e 71
8c167fd9
CBW
72 weaken($y->{Self});
73 ok( ref($y) );
74 }
f4a2945e 75
8c167fd9
CBW
76 ok( $flag == 1 );
77 undef $flag;
78}
f4a2945e 79
8c167fd9 80# a more complicated circular structure
f4a2945e 81{
8c167fd9
CBW
82 $flag = 0;
83
84 {
85 my $y = bless {}, 'Dest';
86 my $x = bless {}, 'Dest';
87 $x->{Ref} = $y;
88 $y->{Ref} = $x;
89 $x->{Flag} = \$flag;
90 $y->{Flag} = \$flag;
91
92 weaken($x->{Ref});
93 }
94 ok( $flag == 2 );
f4a2945e 95}
f4a2945e 96
8c167fd9 97# deleting a weakref before the other one
f4a2945e 98{
8c167fd9
CBW
99 my ($y,$z);
100 {
101 my $x = "foo";
102 $y = \$x;
103 $z = \$x;
104 }
105
106 weaken($y);
107 undef($y);
108
109 ok(not defined $y);
110 ok(ref($z) );
f4a2945e 111}
f4a2945e 112
8c167fd9 113# isweakref
f4a2945e 114{
8c167fd9
CBW
115 $a = 5;
116 ok(!isweak($a));
117 $b = \$a;
118 ok(!isweak($b));
119 weaken($b);
120 ok(isweak($b));
121 $b = \$a;
122 ok(!isweak($b));
123
124 my $x = {};
125 weaken($x->{Y} = \$a);
126 ok(isweak($x->{Y}));
127 ok(!isweak($x->{Z}));
f4a2945e
JH
128}
129
8c167fd9
CBW
130# unweaken
131{
132 my ($y,$z);
133 {
134 my $x = "foo";
135 $y = \$x;
136 $z = \$x;
137 }
138
139 weaken($y);
140
141 ok(isweak($y), '$y is weak after weaken()');
142 is($$y, "foo", '$y points at \"foo" after weaken()');
f4a2945e 143
8c167fd9 144 unweaken($y);
f4a2945e 145
568d025d 146 is(ref $y, "SCALAR", '$y is still a SCALAR ref after unweaken()');
8c167fd9
CBW
147 ok(!isweak($y), '$y is not weak after unweaken()');
148 is($$y, "foo", '$y points at \"foo" after unweaken()');
f4a2945e 149
8c167fd9
CBW
150 undef $z;
151 ok(defined $y, '$y still defined after undef $z');
152}
f4a2945e 153
8c167fd9
CBW
154# test weaken on a read only ref
155SKIP: {
156 # Doesn't work for older perls, see bug [perl #24506]
157 skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
f4a2945e 158
8c167fd9
CBW
159 # in a MAD build, constants have refcnt 2, not 1
160 skip("Test does not work with MAD", 5) if exists $Config{mad};
f4a2945e 161
8c167fd9
CBW
162 $a = eval '\"hello"';
163 ok(ref($a)) or print "# didn't get a ref from eval\n";
f4a2945e 164
8c167fd9
CBW
165 $b = $a;
166 eval { weaken($b) };
167 # we didn't die
168 is($@, "");
169 ok(isweak($b));
170 is($$b, "hello");
e6469971 171
8c167fd9
CBW
172 $a="";
173 ok(not $b) or diag("b did not go away");
e6469971 174}
f4a2945e
JH
175
176package Dest;
177
178sub DESTROY {
8c167fd9 179 ${$_[0]{Flag}} ++;
f4a2945e 180}