home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / tie.t < prev    next >
Text File  |  2000-03-12  |  3KB  |  173 lines
  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. unshift @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
  173.