1package Ties; 2use warnings; # Remove this for production. Assumes perl 5.6 3use strict; 4 5my $ties = 0; 6 7sub count { 8 return $ties; 9} 10 11END { 12 die "You still have ties hanging" if $ties; 13} 14 15package Stie; 16my $sfetches = 0; 17 18sub TIESCALAR { 19 my ($class, $value) = @_; 20 $ties++; 21 return bless [$value], $class; 22} 23 24sub FETCH { 25 $sfetches++; 26 return shift->[0]; 27} 28 29sub DESTROY { 30 $ties--; 31} 32 33sub fetches { 34 my $old = $sfetches; 35 $sfetches = 0; 36 return $old; 37} 38 39package Atie; 40my $afetches = 0; 41sub TIEARRAY { 42 my $class = shift; 43 $ties++; 44 return bless {foo => \@_}, $class; 45} 46 47sub FETCH { 48 $afetches++; 49 # main::diag("Array fetch @_"); 50 return $_[0]->{foo}[$_[1]]; 51} 52 53sub FETCHSIZE { 54 return scalar @{shift->{foo}}; 55} 56 57sub DESTROY { 58 $ties--; 59} 60 61sub fetches { 62 my $old = $afetches; 63 $afetches = 0; 64 return $old; 65} 66 67package Htie; 68my $hfetches = 0; 69sub TIEHASH { 70 my ($class, %hash) = @_; 71 $ties++; 72 return bless [\%hash], $class; 73} 74 75sub FETCH { 76 $hfetches++; 77 return $_[0][0]{$_[1]}; 78} 79 80sub FIRSTKEY { 81 my $array = shift; 82 keys %{$array->[0]}; # reset each 83 return each %{$array->[0]}; 84} 85 86sub NEXTKEY { 87 my $array = shift; 88 return each %{$array->[0]}; 89} 90 91sub EXISTS { 92 return exists $_[0][0]{$_[1]}; 93} 94 95sub DESTROY { 96 $ties--; 97} 98 99sub fetches { 100 my $old = $hfetches; 101 $hfetches = 0; 102 return $old; 103} 104 1051; 106