contrib/perl5/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 warning 'untie';
  81 local $^W = 1 ;
  82 use Tie::Hash ;
  83 tie %h, Tie::StdHash;
  84 untie %h;
  85 EXPECT
  86 ########
  87
  88 # strict behaviour, with 1 extra references generating an error
  89 #use warning 'untie';
  90 local $^W = 1 ;
  91 use Tie::Hash ;
  92 $a = tie %h, Tie::StdHash;
  93 untie %h;
  94 EXPECT
  95 untie attempted while 1 inner references still exist
  96 ########
  97
  98 # strict behaviour, with 1 extra references via tied generating an error
  99 #use warning 'untie';
 100 local $^W = 1 ;
 101 use Tie::Hash ;
 102 tie %h, Tie::StdHash;
 103 $a = tied %h;
 104 untie %h;
 105 EXPECT
 106 untie attempted while 1 inner references still exist
 107 ########
 108
 109 # strict behaviour, with 1 extra references which are destroyed
 110 #use warning 'untie';
 111 local $^W = 1 ;
 112 use Tie::Hash ;
 113 $a = tie %h, Tie::StdHash;
 114 $a = 0 ;
 115 untie %h;
 116 EXPECT
 117 ########
 118
 119 # strict behaviour, with extra 1 references via tied which are destroyed
 120 #use warning 'untie';
 121 local $^W = 1 ;
 122 use Tie::Hash ;
 123 tie %h, Tie::StdHash;
 124 $a = tied %h;
 125 $a = 0 ;
 126 untie %h;
 127 EXPECT
 128 ########
 129
 130 # strict error behaviour, with 2 extra references
 131 #use warning 'untie';
 132 local $^W = 1 ;
 133 use Tie::Hash ;
 134 $a = tie %h, Tie::StdHash;
 135 $b = tied %h ;
 136 untie %h;
 137 EXPECT
 138 untie attempted while 2 inner references still exist
 139 ########
 140
 141 # strict behaviour, check scope of strictness.
 142 #no warning 'untie';
 143 local $^W = 0 ;
 144 use Tie::Hash ;
 145 $A = tie %H, Tie::StdHash;
 146 $C = $B = tied %H ;
 147 {
 148     #use warning 'untie';
 149     local $^W = 1 ;
 150     use Tie::Hash ;
 151     tie %h, Tie::StdHash;
 152     untie %h;
 153 }
 154 untie %H;
 155 EXPECT
 156 ########
 157
 158 # verify no leak when underlying object is selfsame tied variable
 159 my ($a, $b);
 160 sub Self::TIEHASH { bless $_[1], $_[0] }
 161 sub Self::DESTROY { $b = $_[0] + 0; }
 162 {
 163     my %b5;
 164     $a = \%b5 + 0;
 165     tie %b5, 'Self', \%b5;
 166 }
 167 die unless $a == $b;
 168 EXPECT