xref: /openbsd/gnu/usr.bin/perl/dist/Storable/t/weak.t (revision cecf84d4) 
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);
33require 'testlib.pl';
34use vars '$file';
35use strict;
36
37sub 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
45my $r = {};
46my $s1 = [$r, $r];
47weaken $s1->[1];
48ok (isweak($s1->[1]), "element 1 is a weak reference");
49
50my $s0 = [$r, $r];
51weaken $s0->[0];
52ok (isweak($s0->[0]), "element 0 is a weak reference");
53
54my $w = [$r];
55weaken $w->[0];
56ok (isweak($w->[0]), "element 0 is a weak reference");
57
58package OVERLOADED;
59
60use overload
61	'""' => sub { $_[0][0] };
62
63package main;
64
65$a = bless [77], 'OVERLOADED';
66
67my $o = [$a, $a];
68weaken $o->[0];
69ok (isweak($o->[0]), "element 0 is a weak reference");
70
71my @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,
108sub {
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
121foreach (@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}
144