t/op/tie.t

   1 #!./perl
   2
   3 # Add new tests to the end with format:
   4 # "########\n# test description\nTest code\nEXPECT\nWarn or die msgs (if any)\n"
   5 #
   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.
  10
  11 chdir 't' if -d 't';
  12 @INC = '../lib';
  13 $ENV{PERL5LIB} = "../lib";
  14
  15 $|=1;
  16
  17 # catch warnings into fatal errors
  18 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
  19 $SIG{__DIE__}  = sub { die @_ };
  20
  21 undef $/;
  22 @prgs = split /^########\n/m, <DATA>;
  23 print "1..", scalar @prgs, "\n";
  24
  25 for (@prgs){
  26     ++$i;
  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/;
  31     $testname ||= '';
  32     eval "$prog" ;
  33     $status = $?;
  34     $results = $@ ;
  35     $results =~ s/\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";
  44     }
  45     else {
  46         print "ok $i $testname\n";
  47     }
  48 }
  49
  50 __END__
  51
  52 # standard behaviour, without any extra references
  53 use Tie::Hash ;
  54 tie %h, Tie::StdHash;
  55 untie %h;
  56 EXPECT
  57 ########
  58
  59 # standard behaviour, without any extra references
  60 use Tie::Hash ;
  61 {package Tie::HashUntie;
  62  use base 'Tie::StdHash';
  63  sub UNTIE
  64   {
  65    warn "Untied\n";
  66   }
  67 }
  68 tie %h, Tie::HashUntie;
  69 untie %h;
  70 EXPECT
  71 Untied
  72 ########
  73
  74 # standard behaviour, with 1 extra reference
  75 use Tie::Hash ;
  76 $a = tie %h, Tie::StdHash;
  77 untie %h;
  78 EXPECT
  79 ########
  80
  81 # standard behaviour, with 1 extra reference via tied
  82 use Tie::Hash ;
  83 tie %h, Tie::StdHash;
  84 $a = tied %h;
  85 untie %h;
  86 EXPECT
  87 ########
  88
  89 # standard behaviour, with 1 extra reference which is destroyed
  90 use Tie::Hash ;
  91 $a = tie %h, Tie::StdHash;
  92 $a = 0 ;
  93 untie %h;
  94 EXPECT
  95 ########
  96
  97 # standard behaviour, with 1 extra reference via tied which is destroyed
  98 use Tie::Hash ;
  99 tie %h, Tie::StdHash;
 100 $a = tied %h;
 101 $a = 0 ;
 102 untie %h;
 103 EXPECT
 104 ########
 105
 106 # strict behaviour, without any extra references
 107 use warnings 'untie';
 108 use Tie::Hash ;
 109 tie %h, Tie::StdHash;
 110 untie %h;
 111 EXPECT
 112 ########
 113
 114 # strict behaviour, with 1 extra references generating an error
 115 use warnings 'untie';
 116 use Tie::Hash ;
 117 $a = tie %h, Tie::StdHash;
 118 untie %h;
 119 EXPECT
 120 untie attempted while 1 inner references still exist
 121 ########
 122
 123 # strict behaviour, with 1 extra references via tied generating an error
 124 use warnings 'untie';
 125 use Tie::Hash ;
 126 tie %h, Tie::StdHash;
 127 $a = tied %h;
 128 untie %h;
 129 EXPECT
 130 untie attempted while 1 inner references still exist
 131 ########
 132
 133 # strict behaviour, with 1 extra references which are destroyed
 134 use warnings 'untie';
 135 use Tie::Hash ;
 136 $a = tie %h, Tie::StdHash;
 137 $a = 0 ;
 138 untie %h;
 139 EXPECT
 140 ########
 141
 142 # strict behaviour, with extra 1 references via tied which are destroyed
 143 use warnings 'untie';
 144 use Tie::Hash ;
 145 tie %h, Tie::StdHash;
 146 $a = tied %h;
 147 $a = 0 ;
 148 untie %h;
 149 EXPECT
 150 ########
 151
 152 # strict error behaviour, with 2 extra references
 153 use warnings 'untie';
 154 use Tie::Hash ;
 155 $a = tie %h, Tie::StdHash;
 156 $b = tied %h ;
 157 untie %h;
 158 EXPECT
 159 untie attempted while 2 inner references still exist
 160 ########
 161
 162 # strict behaviour, check scope of strictness.
 163 no warnings 'untie';
 164 use Tie::Hash ;
 165 $A = tie %H, Tie::StdHash;
 166 $C = $B = tied %H ;
 167 {
 168     use warnings 'untie';
 169     use Tie::Hash ;
 170     tie %h, Tie::StdHash;
 171     untie %h;
 172 }
 173 untie %H;
 174 EXPECT
 175 ########
 176 # Forbidden aggregate self-ties
 177 sub Self::TIEHASH { bless $_[1], $_[0] }
 178 {
 179     my %c;
 180     tie %c, 'Self', \%c;
 181 }
 182 EXPECT
 183 Self-ties of arrays and hashes are not supported
 184 ########
 185 # Allowed scalar self-ties
 186 my $destroyed = 0;
 187 sub Self::TIESCALAR { bless $_[1], $_[0] }
 188 sub Self::DESTROY   { $destroyed = 1; }
 189 {
 190     my $c = 42;
 191     tie $c, 'Self', \$c;
 192 }
 193 die "self-tied scalar not DESTROYd" unless $destroyed == 1;
 194 EXPECT
 195 ########
 196 # Allowed glob self-ties
 197 my $destroyed = 0;
 198 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
 199 sub Self2::DESTROY   { $destroyed = 1; }
 200 {
 201     use Symbol;
 202     my $c = gensym;
 203     tie *$c, 'Self2', $c;
 204 }
 205 die "self-tied glob not DESTROYd" unless $destroyed == 1;
 206 EXPECT
 207 ########
 208 # Allowed IO self-ties
 209 my $destroyed = 0;
 210 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 211 sub Self3::DESTROY   { $destroyed = 1; }
 212 {
 213     use Symbol 'geniosym';
 214     my $c = geniosym;
 215     tie *$c, 'Self3', $c;
 216 }
 217 die "self-tied IO not DESTROYd" unless $destroyed == 1;
 218 EXPECT
 219 ########
 220 # Interaction of tie and vec
 221
 222 my ($a, $b);
 223 use Tie::Scalar;
 224 tie $a,Tie::StdScalar or die;
 225 vec($b,1,1)=1;
 226 $a = $b;
 227 vec($a,1,1)=0;
 228 vec($b,1,1)=0;
 229 die unless $a eq $b;
 230 EXPECT
 231 ########
 232 # correct unlocalisation of tied hashes (patch #16431)
 233 use Tie::Hash ;
 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'};
 238 EXPECT
 239