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
  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+$//;
  28     if ( $status or $results and $results !~ /^WARNING: $expected/){
  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, without any extra references
  48 use Tie::Hash ;
  49 {package Tie::HashUntie;
  50  use base 'Tie::StdHash';
  51  sub UNTIE
  52   {
  53    warn "Untied\n";
  54   }
  55 }
  56 tie %h, Tie::HashUntie;
  57 untie %h;
  58 EXPECT
  59 Untied
  60 ########
  61
  62 # standard behaviour, with 1 extra reference
  63 use Tie::Hash ;
  64 $a = tie %h, Tie::StdHash;
  65 untie %h;
  66 EXPECT
  67 ########
  68
  69 # standard behaviour, with 1 extra reference via tied
  70 use Tie::Hash ;
  71 tie %h, Tie::StdHash;
  72 $a = tied %h;
  73 untie %h;
  74 EXPECT
  75 ########
  76
  77 # standard behaviour, with 1 extra reference which is destroyed
  78 use Tie::Hash ;
  79 $a = tie %h, Tie::StdHash;
  80 $a = 0 ;
  81 untie %h;
  82 EXPECT
  83 ########
  84
  85 # standard behaviour, with 1 extra reference via tied which is destroyed
  86 use Tie::Hash ;
  87 tie %h, Tie::StdHash;
  88 $a = tied %h;
  89 $a = 0 ;
  90 untie %h;
  91 EXPECT
  92 ########
  93
  94 # strict behaviour, without any extra references
  95 use warnings 'untie';
  96 use Tie::Hash ;
  97 tie %h, Tie::StdHash;
  98 untie %h;
  99 EXPECT
 100 ########
 101
 102 # strict behaviour, with 1 extra references generating an error
 103 use warnings 'untie';
 104 use Tie::Hash ;
 105 $a = tie %h, Tie::StdHash;
 106 untie %h;
 107 EXPECT
 108 untie attempted while 1 inner references still exist
 109 ########
 110
 111 # strict behaviour, with 1 extra references via tied generating an error
 112 use warnings 'untie';
 113 use Tie::Hash ;
 114 tie %h, Tie::StdHash;
 115 $a = tied %h;
 116 untie %h;
 117 EXPECT
 118 untie attempted while 1 inner references still exist
 119 ########
 120
 121 # strict behaviour, with 1 extra references which are destroyed
 122 use warnings 'untie';
 123 use Tie::Hash ;
 124 $a = tie %h, Tie::StdHash;
 125 $a = 0 ;
 126 untie %h;
 127 EXPECT
 128 ########
 129
 130 # strict behaviour, with extra 1 references via tied which are destroyed
 131 use warnings 'untie';
 132 use Tie::Hash ;
 133 tie %h, Tie::StdHash;
 134 $a = tied %h;
 135 $a = 0 ;
 136 untie %h;
 137 EXPECT
 138 ########
 139
 140 # strict error behaviour, with 2 extra references
 141 use warnings 'untie';
 142 use Tie::Hash ;
 143 $a = tie %h, Tie::StdHash;
 144 $b = tied %h ;
 145 untie %h;
 146 EXPECT
 147 untie attempted while 2 inner references still exist
 148 ########
 149
 150 # strict behaviour, check scope of strictness.
 151 no warnings 'untie';
 152 use Tie::Hash ;
 153 $A = tie %H, Tie::StdHash;
 154 $C = $B = tied %H ;
 155 {
 156     use warnings 'untie';
 157     use Tie::Hash ;
 158     tie %h, Tie::StdHash;
 159     untie %h;
 160 }
 161 untie %H;
 162 EXPECT
 163 ########
 164
 165 # verify no leak when underlying object is selfsame tied variable
 166 my ($a, $b);
 167 sub Self::TIEHASH { bless $_[1], $_[0] }
 168 sub Self::DESTROY { $b = $_[0] + 0; }
 169 {
 170     my %b5;
 171     $a = \%b5 + 0;
 172     tie %b5, 'Self', \%b5;
 173 }
 174 die unless $a == $b;
 175 EXPECT
 176 ########
 177 # Interaction of tie and vec
 178
 179 my ($a, $b);
 180 use Tie::Scalar;
 181 tie $a,Tie::StdScalar or die;
 182 vec($b,1,1)=1;
 183 $a = $b;
 184 vec($a,1,1)=0;
 185 vec($b,1,1)=0;
 186 die unless $a eq $b;
 187 EXPECT