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, 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
  80 use warnings 'untie';
  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
  88 use warnings 'untie';
  89 use Tie::Hash ;
  90 $a = tie %h, Tie::StdHash;
  91 untie %h;
  92 EXPECT
  93 untie attempted while 1 inner references still exist
  94 ########
  95
  96 # strict behaviour, with 1 extra references via tied generating an error
  97 use warnings 'untie';
  98 use Tie::Hash ;
  99 tie %h, Tie::StdHash;
 100 $a = tied %h;
 101 untie %h;
 102 EXPECT
 103 untie attempted while 1 inner references still exist
 104 ########
 105
 106 # strict behaviour, with 1 extra references which are destroyed
 107 use warnings 'untie';
 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
 116 use warnings 'untie';
 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
 126 use warnings 'untie';
 127 use Tie::Hash ;
 128 $a = tie %h, Tie::StdHash;
 129 $b = tied %h ;
 130 untie %h;
 131 EXPECT
 132 untie attempted while 2 inner references still exist
 133 ########
 134
 135 # strict behaviour, check scope of strictness.
 136 no warnings 'untie';
 137 use Tie::Hash ;
 138 $A = tie %H, Tie::StdHash;
 139 $C = $B = tied %H ;
 140 {
 141     use warnings 'untie';
 142     use Tie::Hash ;
 143     tie %h, Tie::StdHash;
 144     untie %h;
 145 }
 146 untie %H;
 147 EXPECT
 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
 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