t/op/tie.t

   1 #!./perl
   2
   3 # This test harness will (eventually) test the "tie" functionality
   4 # without the need for a *DBM* implementation.
   5
   6 # Currently it only tests the untie warning
   7
   8 chdir 't' if -d 't';
   9 @INC = '../lib';
  10 $ENV{PERL5LIB} = "../lib";
  11
  12 $|=1;
  13
  14 # catch warnings into fatal errors
  15 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
  16 $SIG{__DIE__}  = sub { die @_ };
  17
  18 undef $/;
  19 @prgs = split "\n########\n", <DATA>;
  20 print "1..", scalar @prgs, "\n";
  21
  22 for (@prgs){
  23     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  24     eval "$prog" ;
  25     $status = $?;
  26     $results = $@ ;
  27     $results =~ s/\n+$//;
  28     $expected =~ s/\n+$//;
  29     if ( $status or $results and $results !~ /^(WARNING: )?$expected/){
  30         print STDERR "STATUS: $status\n";
  31         print STDERR "PROG: $prog\n";
  32         print STDERR "EXPECTED:\n$expected\n";
  33         print STDERR "GOT:\n$results\n";
  34         print "not ";
  35     }
  36     print "ok ", ++$i, "\n";
  37 }
  38
  39 __END__
  40
  41 # standard behaviour, without any extra references
  42 use Tie::Hash ;
  43 tie %h, Tie::StdHash;
  44 untie %h;
  45 EXPECT
  46 ########
  47
  48 # standard behaviour, without any extra references
  49 use Tie::Hash ;
  50 {package Tie::HashUntie;
  51  use base 'Tie::StdHash';
  52  sub UNTIE
  53   {
  54    warn "Untied\n";
  55   }
  56 }
  57 tie %h, Tie::HashUntie;
  58 untie %h;
  59 EXPECT
  60 Untied
  61 ########
  62
  63 # standard behaviour, with 1 extra reference
  64 use Tie::Hash ;
  65 $a = tie %h, Tie::StdHash;
  66 untie %h;
  67 EXPECT
  68 ########
  69
  70 # standard behaviour, with 1 extra reference via tied
  71 use Tie::Hash ;
  72 tie %h, Tie::StdHash;
  73 $a = tied %h;
  74 untie %h;
  75 EXPECT
  76 ########
  77
  78 # standard behaviour, with 1 extra reference which is destroyed
  79 use Tie::Hash ;
  80 $a = tie %h, Tie::StdHash;
  81 $a = 0 ;
  82 untie %h;
  83 EXPECT
  84 ########
  85
  86 # standard behaviour, with 1 extra reference via tied which is destroyed
  87 use Tie::Hash ;
  88 tie %h, Tie::StdHash;
  89 $a = tied %h;
  90 $a = 0 ;
  91 untie %h;
  92 EXPECT
  93 ########
  94
  95 # strict behaviour, without any extra references
  96 use warnings 'untie';
  97 use Tie::Hash ;
  98 tie %h, Tie::StdHash;
  99 untie %h;
 100 EXPECT
 101 ########
 102
 103 # strict behaviour, with 1 extra references generating an error
 104 use warnings 'untie';
 105 use Tie::Hash ;
 106 $a = tie %h, Tie::StdHash;
 107 untie %h;
 108 EXPECT
 109 untie attempted while 1 inner references still exist
 110 ########
 111
 112 # strict behaviour, with 1 extra references via tied generating an error
 113 use warnings 'untie';
 114 use Tie::Hash ;
 115 tie %h, Tie::StdHash;
 116 $a = tied %h;
 117 untie %h;
 118 EXPECT
 119 untie attempted while 1 inner references still exist
 120 ########
 121
 122 # strict behaviour, with 1 extra references which are destroyed
 123 use warnings 'untie';
 124 use Tie::Hash ;
 125 $a = tie %h, Tie::StdHash;
 126 $a = 0 ;
 127 untie %h;
 128 EXPECT
 129 ########
 130
 131 # strict behaviour, with extra 1 references via tied which are destroyed
 132 use warnings 'untie';
 133 use Tie::Hash ;
 134 tie %h, Tie::StdHash;
 135 $a = tied %h;
 136 $a = 0 ;
 137 untie %h;
 138 EXPECT
 139 ########
 140
 141 # strict error behaviour, with 2 extra references
 142 use warnings 'untie';
 143 use Tie::Hash ;
 144 $a = tie %h, Tie::StdHash;
 145 $b = tied %h ;
 146 untie %h;
 147 EXPECT
 148 untie attempted while 2 inner references still exist
 149 ########
 150
 151 # strict behaviour, check scope of strictness.
 152 no warnings 'untie';
 153 use Tie::Hash ;
 154 $A = tie %H, Tie::StdHash;
 155 $C = $B = tied %H ;
 156 {
 157     use warnings 'untie';
 158     use Tie::Hash ;
 159     tie %h, Tie::StdHash;
 160     untie %h;
 161 }
 162 untie %H;
 163 EXPECT
 164 ########
 165 # Forbidden aggregate self-ties
 166 my ($a, $b) = (0, 0);
 167 sub Self::TIEHASH { bless $_[1], $_[0] }
 168 sub Self::DESTROY { $b = $_[0] + 1; }
 169 {
 170     my %c = 42;
 171     tie %c, 'Self', \%c;
 172 }
 173 EXPECT
 174 Self-ties of arrays and hashes are not supported
 175 ########
 176 # Allowed scalar self-ties
 177 my ($a, $b) = (0, 0);
 178 sub Self::TIESCALAR { bless $_[1], $_[0] }
 179 sub Self::DESTROY   { $b = $_[0] + 1; }
 180 {
 181     my $c = 42;
 182     $a = $c + 0;
 183     tie $c, 'Self', \$c;
 184 }
 185 die unless $a == 0 && $b == 43;
 186 EXPECT
 187 ########
 188 # Interaction of tie and vec
 189
 190 my ($a, $b);
 191 use Tie::Scalar;
 192 tie $a,Tie::StdScalar or die;
 193 vec($b,1,1)=1;
 194 $a = $b;
 195 vec($a,1,1)=0;
 196 vec($b,1,1)=0;
 197 die unless $a eq $b;
 198 EXPECT
 199 ########
 200 # An attempt at lvalueable barewords broke this
 201
 202 tie FH, 'main';
 203 EXPECT
 204