3 # Add new tests to the end with format:
4 # "########\n# test description\nTest code\nEXPECT\nWarn or die msgs (if any)\n"
6 # This test script does NOT test the output of the test code. It ONLY
7 # checks warnings or croaks. Todo tests should have TODO as the start
8 # of the description. Note also that warnings are not enabled: if you
9 # need to test a perl warning, enable its class in your test.
13 $ENV{PERL5LIB} = "../lib";
17 # catch warnings into fatal errors
18 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
19 $SIG{__DIE__} = sub { die @_ };
22 @prgs = split /^########\n/m, <DATA>;
23 print "1..", scalar @prgs, "\n";
27 my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
28 print("not ok $i # bad test format\n"), next
29 unless defined $expected;
30 my ($testname) = $prog =~ /^\n?(# .*)\n/;
36 $expected =~ s/\n+$//;
37 if ( $status || ($expected eq '') != ($results eq '') ||
38 $results !~ /^(WARNING: )?$expected/){
39 print STDERR "STATUS: $status\n";
40 print STDERR "PROG: $prog\n";
41 print STDERR "EXPECTED:\n$expected\n";
42 print STDERR "GOT:\n$results\n";
43 print "not ok $i $testname\n";
46 print "ok $i $testname\n";
52 # standard behaviour, without any extra references
59 # standard behaviour, without any extra references
61 {package Tie::HashUntie;
62 use base 'Tie::StdHash';
68 tie %h, Tie::HashUntie;
74 # standard behaviour, with 1 extra reference
76 $a = tie %h, Tie::StdHash;
81 # standard behaviour, with 1 extra reference via tied
89 # standard behaviour, with 1 extra reference which is destroyed
91 $a = tie %h, Tie::StdHash;
97 # standard behaviour, with 1 extra reference via tied which is destroyed
106 # strict behaviour, without any extra references
107 use warnings 'untie';
109 tie %h, Tie::StdHash;
114 # strict behaviour, with 1 extra references generating an error
115 use warnings 'untie';
117 $a = tie %h, Tie::StdHash;
120 untie attempted while 1 inner references still exist
123 # strict behaviour, with 1 extra references via tied generating an error
124 use warnings 'untie';
126 tie %h, Tie::StdHash;
130 untie attempted while 1 inner references still exist
133 # strict behaviour, with 1 extra references which are destroyed
134 use warnings 'untie';
136 $a = tie %h, Tie::StdHash;
142 # strict behaviour, with extra 1 references via tied which are destroyed
143 use warnings 'untie';
145 tie %h, Tie::StdHash;
152 # strict error behaviour, with 2 extra references
153 use warnings 'untie';
155 $a = tie %h, Tie::StdHash;
159 untie attempted while 2 inner references still exist
162 # strict behaviour, check scope of strictness.
165 $A = tie %H, Tie::StdHash;
168 use warnings 'untie';
170 tie %h, Tie::StdHash;
176 # Forbidden aggregate self-ties
177 sub Self::TIEHASH { bless $_[1], $_[0] }
183 Self-ties of arrays and hashes are not supported
185 # Allowed scalar self-ties
187 sub Self::TIESCALAR { bless $_[1], $_[0] }
188 sub Self::DESTROY { $destroyed = 1; }
193 die "self-tied scalar not DESTROYd" unless $destroyed == 1;
196 # Allowed glob self-ties
198 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
199 sub Self2::DESTROY { $destroyed = 1; }
203 tie *$c, 'Self2', $c;
205 die "self-tied glob not DESTROYd" unless $destroyed == 1;
208 # Allowed IO self-ties
210 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
211 sub Self3::DESTROY { $destroyed = 1; }
213 use Symbol 'geniosym';
215 tie *$c, 'Self3', $c;
217 die "self-tied IO not DESTROYd" unless $destroyed == 1;
220 # Interaction of tie and vec
224 tie $a,Tie::StdScalar or die;
232 # correct unlocalisation of tied hashes (patch #16431)
234 tie %tied, Tie::StdHash;
235 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
236 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
237 { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};