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