1#!./perl -w
2#
3#  Copyright 2004, Larry Wall.
4#
5#  You may redistribute only under the same terms as Perl 5, as specified
6#  in the README file that comes with the distribution.
7#
8
9sub BEGIN {
10  # This lets us distribute Test::More in t/
11  unshift @INC, 't';
12  unshift @INC, 't/compat' if $] < 5.006002;
13  require Config; import Config;
14  if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
15    print "1..0 # Skip: Storable was not built\n";
16    exit 0;
17  }
18  if ($Config{extensions} !~ /\bList\/Util\b/) {
19    print "1..0 # Skip: List::Util was not built\n";
20    exit 0;
21  }
22
23  require Scalar::Util;
24  Scalar::Util->import(qw(weaken isweak));
25  if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
26    print("1..0 # Skip: No support for weaken in Scalar::Util\n");
27    exit 0;
28  }
29}
30
31use Test::More 'no_plan';
32use Storable qw (store retrieve freeze thaw nstore nfreeze dclone);
33require 'testlib.pl';
34our $file;
35use strict;
36
37# $Storable::flags = Storable::FLAGS_COMPAT;
38
39sub tester {
40  my ($contents, $sub, $testersub, $what) = @_;
41  # Test that if we re-write it, everything still works:
42  my $clone = &$sub ($contents);
43  is ($@, "", "There should be no error extracting for $what");
44  &$testersub ($clone, $what);
45}
46
47my $r = {};
48my $s1 = [$r, $r];
49weaken $s1->[1];
50ok (isweak($s1->[1]), "element 1 is a weak reference");
51
52my $s0 = [$r, $r];
53weaken $s0->[0];
54ok (isweak($s0->[0]), "element 0 is a weak reference");
55
56my $w = [$r];
57weaken $w->[0];
58ok (isweak($w->[0]), "element 0 is a weak reference");
59
60package OVERLOADED;
61
62use overload
63	'""' => sub { $_[0][0] };
64
65package main;
66
67$a = bless [77], 'OVERLOADED';
68
69my $o = [$a, $a];
70weaken $o->[0];
71ok (isweak($o->[0]), "element 0 is a weak reference");
72
73my @tests = (
74[$s1,
75 sub  {
76  my ($clone, $what) = @_;
77  isa_ok($clone,'ARRAY');
78  isa_ok($clone->[0],'HASH');
79  isa_ok($clone->[1],'HASH');
80  ok(!isweak $clone->[0], "Element 0 isn't weak");
81  ok(isweak $clone->[1], "Element 1 is weak");
82}
83],
84# The weak reference needs to hang around long enough for other stuff to
85# be able to make references to it. So try it second.
86[$s0,
87 sub  {
88  my ($clone, $what) = @_;
89  isa_ok($clone,'ARRAY');
90  isa_ok($clone->[0],'HASH');
91  isa_ok($clone->[1],'HASH');
92  ok(isweak $clone->[0], "Element 0 is weak");
93  ok(!isweak $clone->[1], "Element 1 isn't weak");
94}
95],
96[$w,
97 sub  {
98  my ($clone, $what) = @_;
99  isa_ok($clone,'ARRAY');
100  if ($what eq 'nothing') {
101    # We're the original, so we're still a weakref to a hash
102    isa_ok($clone->[0],'HASH');
103    ok(isweak $clone->[0], "Element 0 is weak");
104  } else {
105    is($clone->[0],undef);
106  }
107}
108],
109[$o,
110sub {
111  my ($clone, $what) = @_;
112  isa_ok($clone,'ARRAY');
113  isa_ok($clone->[0],'OVERLOADED');
114  isa_ok($clone->[1],'OVERLOADED');
115  ok(isweak $clone->[0], "Element 0 is weak");
116  ok(!isweak $clone->[1], "Element 1 isn't weak");
117  is ("$clone->[0]", 77, "Element 0 stringifies to 77");
118  is ("$clone->[1]", 77, "Element 1 stringifies to 77");
119}
120],
121);
122
123foreach (@tests) {
124  my ($input, $testsub) = @$_;
125
126  tester($input, sub {return shift}, $testsub, 'nothing');
127
128  ok (defined store($input, $file));
129
130  # Read the contents into memory:
131  my $contents = slurp ($file);
132
133  tester($contents, \&store_and_retrieve, $testsub, 'file');
134
135  # And now try almost everything again with a Storable string
136  my $stored = freeze $input;
137  tester($stored, \&freeze_and_thaw, $testsub, 'string');
138
139  ok (defined nstore($input, $file));
140
141  tester($contents, \&store_and_retrieve, $testsub, 'network file');
142
143  $stored = nfreeze $input;
144  tester($stored, \&freeze_and_thaw, $testsub, 'network string');
145}
146
147{
148    # [perl #134179] sv_upgrade from type 7 down to type 1
149    my $foo = [qr//,[]];
150    weaken($foo->[1][0][0] = $foo->[1]);
151    my $out = dclone($foo); # croaked here
152    is_deeply($out, $foo, "check they match");
153}
154