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