Commit | Line | Data |
---|---|---|
c3c53033 NC |
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 | ||
9 | sub BEGIN { | |
48c887dd NC |
10 | # This lets us distribute Test::More in t/ |
11 | unshift @INC, 't'; | |
1afdebce | 12 | unshift @INC, 't/compat' if $] < 5.006002; |
c3c53033 NC |
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; | |
fac63a07 | 24 | Scalar::Util->import(qw(weaken isweak)); |
c3c53033 NC |
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 | ||
31 | use Test::More 'no_plan'; | |
32 | use Storable qw (store retrieve freeze thaw nstore nfreeze); | |
33 | require 'testlib.pl'; | |
34 | use vars '$file'; | |
35 | use strict; | |
36 | ||
37 | sub tester { | |
38 | my ($contents, $sub, $testersub, $what) = @_; | |
39 | # Test that if we re-write it, everything still works: | |
40 | my $clone = &$sub ($contents); | |
41 | is ($@, "", "There should be no error extracting for $what"); | |
42 | &$testersub ($clone, $what); | |
43 | } | |
44 | ||
45 | my $r = {}; | |
46 | my $s1 = [$r, $r]; | |
47 | weaken $s1->[1]; | |
48 | ok (isweak($s1->[1]), "element 1 is a weak reference"); | |
49 | ||
50 | my $s0 = [$r, $r]; | |
51 | weaken $s0->[0]; | |
52 | ok (isweak($s0->[0]), "element 0 is a weak reference"); | |
53 | ||
54 | my $w = [$r]; | |
55 | weaken $w->[0]; | |
56 | ok (isweak($w->[0]), "element 0 is a weak reference"); | |
57 | ||
58 | package OVERLOADED; | |
59 | ||
60 | use overload | |
61 | '""' => sub { $_[0][0] }; | |
62 | ||
63 | package main; | |
64 | ||
65 | $a = bless [77], 'OVERLOADED'; | |
66 | ||
67 | my $o = [$a, $a]; | |
68 | weaken $o->[0]; | |
69 | ok (isweak($o->[0]), "element 0 is a weak reference"); | |
70 | ||
71 | my @tests = ( | |
72 | [$s1, | |
73 | sub { | |
74 | my ($clone, $what) = @_; | |
75 | isa_ok($clone,'ARRAY'); | |
76 | isa_ok($clone->[0],'HASH'); | |
77 | isa_ok($clone->[1],'HASH'); | |
78 | ok(!isweak $clone->[0], "Element 0 isn't weak"); | |
79 | ok(isweak $clone->[1], "Element 1 is weak"); | |
80 | } | |
81 | ], | |
82 | # The weak reference needs to hang around long enough for other stuff to | |
83 | # be able to make references to it. So try it second. | |
84 | [$s0, | |
85 | sub { | |
86 | my ($clone, $what) = @_; | |
87 | isa_ok($clone,'ARRAY'); | |
88 | isa_ok($clone->[0],'HASH'); | |
89 | isa_ok($clone->[1],'HASH'); | |
90 | ok(isweak $clone->[0], "Element 0 is weak"); | |
91 | ok(!isweak $clone->[1], "Element 1 isn't weak"); | |
92 | } | |
93 | ], | |
94 | [$w, | |
95 | sub { | |
96 | my ($clone, $what) = @_; | |
97 | isa_ok($clone,'ARRAY'); | |
98 | if ($what eq 'nothing') { | |
99 | # We're the original, so we're still a weakref to a hash | |
100 | isa_ok($clone->[0],'HASH'); | |
101 | ok(isweak $clone->[0], "Element 0 is weak"); | |
102 | } else { | |
103 | is($clone->[0],undef); | |
104 | } | |
105 | } | |
106 | ], | |
107 | [$o, | |
108 | sub { | |
109 | my ($clone, $what) = @_; | |
110 | isa_ok($clone,'ARRAY'); | |
111 | isa_ok($clone->[0],'OVERLOADED'); | |
112 | isa_ok($clone->[1],'OVERLOADED'); | |
113 | ok(isweak $clone->[0], "Element 0 is weak"); | |
114 | ok(!isweak $clone->[1], "Element 1 isn't weak"); | |
115 | is ("$clone->[0]", 77, "Element 0 stringifies to 77"); | |
116 | is ("$clone->[1]", 77, "Element 1 stringifies to 77"); | |
117 | } | |
118 | ], | |
119 | ); | |
120 | ||
121 | foreach (@tests) { | |
122 | my ($input, $testsub) = @$_; | |
123 | ||
124 | tester($input, sub {return shift}, $testsub, 'nothing'); | |
125 | ||
126 | ok (defined store($input, $file)); | |
127 | ||
128 | # Read the contents into memory: | |
129 | my $contents = slurp ($file); | |
130 | ||
131 | tester($contents, \&store_and_retrieve, $testsub, 'file'); | |
132 | ||
133 | # And now try almost everything again with a Storable string | |
134 | my $stored = freeze $input; | |
135 | tester($stored, \&freeze_and_thaw, $testsub, 'string'); | |
136 | ||
137 | ok (defined nstore($input, $file)); | |
138 | ||
139 | tester($contents, \&store_and_retrieve, $testsub, 'network file'); | |
140 | ||
141 | $stored = nfreeze $input; | |
142 | tester($stored, \&freeze_and_thaw, $testsub, 'network string'); | |
143 | } |