Commit | Line | Data |
4fb76cf4 |
1 | #!/usr/bin/env perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use Scalar::Util qw(weaken isweak); |
6 | |
7 | # $X strong -> $Y |
8 | # $Y weak -> $X |
9 | # |
10 | # $Y goes out of scope - all fine |
11 | # |
12 | # $X goes out of scope - need to swap to |
13 | # |
14 | # $X weak -> $Y |
15 | # $Y strong -> $X |
16 | # |
17 | # but not if $Y is already out of scope - so don't do it unless $Y's refcount |
18 | # is >1 |
19 | |
20 | BEGIN { |
21 | package Foo; |
22 | |
23 | use Devel::GlobalDestruction 'in_global_destruction'; |
24 | use Scalar::Util qw(weaken isweak); |
25 | use Devel::Refcount qw(refcount); |
26 | |
27 | sub DESTROY { |
28 | my $self = shift; |
29 | warn "DESTROY fired for $self\n"; |
30 | return if in_global_destruction; |
31 | warn "Not in global destruction\n"; |
32 | return unless isweak $self->{back}{forward}; |
33 | warn "Reference to us is weak\n"; |
34 | return unless $self->{forward}; |
35 | warn "Have forward pointer\n"; |
36 | return unless refcount($self->{forward}) > 1; |
37 | warn "Next in chain has refcount of ".(refcount $self->{forward})."\n"; |
38 | $self->{back}{forward} = $self; #->{back}{forward}; |
39 | weaken $self->{forward}; |
40 | warn "Swapped links - $self now has weak ref to ${\$self->{forward}} and ${\$self->{back}} has a strong ref to $self\n"; |
41 | return; |
42 | } |
43 | } |
44 | |
45 | # set this shit up |
46 | my $one = bless({}, 'Foo'); |
47 | my $two = bless({}, 'Foo'); |
48 | weaken(my $weak_one = $one); |
49 | weaken(my $weak_two = $two); |
50 | $one->{forward} = $two; |
51 | weaken($two->{forward} = $one); |
52 | weaken($one->{back} = $two); |
53 | weaken($two->{back} = $one); |
54 | |
55 | sub status { |
56 | warn "One: ${\($weak_one||'GONE')} Two: ${\($weak_two||'GONE')}\n"; |
57 | warn "One's forward is${\(isweak($weak_one->{forward}) ? '' : ' not')} weak\n" if $weak_one; |
58 | warn "Two's forward is${\(isweak($weak_two->{forward}) ? '' : ' not')} weak\n" if $weak_two; |
59 | } |
60 | |
61 | warn "\$one is $one, \$two is $two"; |
62 | warn "Undefining \$two\n"; |
63 | undef($two); |
64 | status; |
65 | warn "Restoring \$two\n"; |
66 | $two = $weak_two; |
67 | warn "Undefining \$one\n"; |
68 | undef($one); |
69 | status; |
70 | warn "Restoring \$one\n"; |
71 | $one = $weak_one; |
72 | warn "Undefining \$two\n"; |
73 | undef($two); |
74 | status; |
75 | warn "Restoring \$two\n"; |
76 | $two = $weak_two; |
77 | warn "Undefining both\n"; |
78 | undef($one); |
79 | undef($two); |
80 | status; |
81 | warn "Done\n"; |