Commit | Line | Data |
49d42823 |
1 | #!./perl |
2 | |
3 | # This test harness will (eventually) test the "tie" functionality |
4 | # without the need for a *DBM* implementation. |
5 | |
55497cff |
6 | # Currently it only tests the untie warning |
49d42823 |
7 | |
8 | chdir 't' if -d 't'; |
93430cb4 |
9 | unshift @INC, "../lib"; |
49d42823 |
10 | $ENV{PERL5LIB} = "../lib"; |
11 | |
12 | $|=1; |
13 | |
55497cff |
14 | # catch warnings into fatal errors |
15 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; |
16 | |
49d42823 |
17 | undef $/; |
18 | @prgs = split "\n########\n", <DATA>; |
19 | print "1..", scalar @prgs, "\n"; |
20 | |
21 | for (@prgs){ |
22 | my($prog,$expected) = split(/\nEXPECT\n/, $_); |
23 | eval "$prog" ; |
24 | $status = $?; |
25 | $results = $@ ; |
26 | $results =~ s/\n+$//; |
27 | $expected =~ s/\n+$//; |
55497cff |
28 | if ( $status or $results and $results !~ /^WARNING: $expected/){ |
49d42823 |
29 | print STDERR "STATUS: $status\n"; |
30 | print STDERR "PROG: $prog\n"; |
31 | print STDERR "EXPECTED:\n$expected\n"; |
32 | print STDERR "GOT:\n$results\n"; |
33 | print "not "; |
34 | } |
35 | print "ok ", ++$i, "\n"; |
36 | } |
37 | |
38 | __END__ |
39 | |
40 | # standard behaviour, without any extra references |
41 | use Tie::Hash ; |
42 | tie %h, Tie::StdHash; |
43 | untie %h; |
44 | EXPECT |
45 | ######## |
46 | |
47 | # standard behaviour, with 1 extra reference |
48 | use Tie::Hash ; |
49 | $a = tie %h, Tie::StdHash; |
50 | untie %h; |
51 | EXPECT |
52 | ######## |
53 | |
54 | # standard behaviour, with 1 extra reference via tied |
55 | use Tie::Hash ; |
56 | tie %h, Tie::StdHash; |
57 | $a = tied %h; |
58 | untie %h; |
59 | EXPECT |
60 | ######## |
61 | |
62 | # standard behaviour, with 1 extra reference which is destroyed |
63 | use Tie::Hash ; |
64 | $a = tie %h, Tie::StdHash; |
65 | $a = 0 ; |
66 | untie %h; |
67 | EXPECT |
68 | ######## |
69 | |
70 | # standard behaviour, with 1 extra reference via tied which is destroyed |
71 | use Tie::Hash ; |
72 | tie %h, Tie::StdHash; |
73 | $a = tied %h; |
74 | $a = 0 ; |
75 | untie %h; |
76 | EXPECT |
77 | ######## |
78 | |
79 | # strict behaviour, without any extra references |
4438c4b7 |
80 | use warnings 'untie'; |
49d42823 |
81 | use Tie::Hash ; |
82 | tie %h, Tie::StdHash; |
83 | untie %h; |
84 | EXPECT |
85 | ######## |
86 | |
87 | # strict behaviour, with 1 extra references generating an error |
4438c4b7 |
88 | use warnings 'untie'; |
49d42823 |
89 | use Tie::Hash ; |
90 | $a = tie %h, Tie::StdHash; |
91 | untie %h; |
92 | EXPECT |
55497cff |
93 | untie attempted while 1 inner references still exist |
49d42823 |
94 | ######## |
95 | |
96 | # strict behaviour, with 1 extra references via tied generating an error |
4438c4b7 |
97 | use warnings 'untie'; |
49d42823 |
98 | use Tie::Hash ; |
99 | tie %h, Tie::StdHash; |
100 | $a = tied %h; |
101 | untie %h; |
102 | EXPECT |
55497cff |
103 | untie attempted while 1 inner references still exist |
49d42823 |
104 | ######## |
105 | |
106 | # strict behaviour, with 1 extra references which are destroyed |
4438c4b7 |
107 | use warnings 'untie'; |
49d42823 |
108 | use Tie::Hash ; |
109 | $a = tie %h, Tie::StdHash; |
110 | $a = 0 ; |
111 | untie %h; |
112 | EXPECT |
113 | ######## |
114 | |
115 | # strict behaviour, with extra 1 references via tied which are destroyed |
4438c4b7 |
116 | use warnings 'untie'; |
49d42823 |
117 | use Tie::Hash ; |
118 | tie %h, Tie::StdHash; |
119 | $a = tied %h; |
120 | $a = 0 ; |
121 | untie %h; |
122 | EXPECT |
123 | ######## |
124 | |
125 | # strict error behaviour, with 2 extra references |
4438c4b7 |
126 | use warnings 'untie'; |
49d42823 |
127 | use Tie::Hash ; |
128 | $a = tie %h, Tie::StdHash; |
129 | $b = tied %h ; |
130 | untie %h; |
131 | EXPECT |
55497cff |
132 | untie attempted while 2 inner references still exist |
49d42823 |
133 | ######## |
134 | |
135 | # strict behaviour, check scope of strictness. |
4438c4b7 |
136 | no warnings 'untie'; |
49d42823 |
137 | use Tie::Hash ; |
138 | $A = tie %H, Tie::StdHash; |
139 | $C = $B = tied %H ; |
140 | { |
4438c4b7 |
141 | use warnings 'untie'; |
49d42823 |
142 | use Tie::Hash ; |
143 | tie %h, Tie::StdHash; |
144 | untie %h; |
145 | } |
146 | untie %H; |
147 | EXPECT |
33c27489 |
148 | ######## |
149 | |
150 | # verify no leak when underlying object is selfsame tied variable |
151 | my ($a, $b); |
152 | sub Self::TIEHASH { bless $_[1], $_[0] } |
153 | sub Self::DESTROY { $b = $_[0] + 0; } |
154 | { |
155 | my %b5; |
156 | $a = \%b5 + 0; |
157 | tie %b5, 'Self', \%b5; |
158 | } |
159 | die unless $a == $b; |
160 | EXPECT |
7bb043c3 |
161 | ######## |
162 | # Interaction of tie and vec |
163 | |
164 | my ($a, $b); |
165 | use Tie::Scalar; |
166 | tie $a,Tie::StdScalar or die; |
167 | vec($b,1,1)=1; |
168 | $a = $b; |
169 | vec($a,1,1)=0; |
170 | vec($b,1,1)=0; |
171 | die unless $a eq $b; |
172 | EXPECT |