Commit | Line | Data |
a0d0e21e |
1 | package TieHash; |
2 | use Carp; |
3 | |
4 | sub new { |
5 | my $pack = shift; |
6 | $pack->TIEHASH(@_); |
7 | } |
8 | |
9 | # Grandfather "new" |
10 | |
11 | sub TIEHASH { |
12 | my $pack = shift; |
5d94fbed |
13 | if (defined &{"$pack\::new"}) { |
14 | carp "WARNING: calling $pack\->new since $pack\->TIEHASH is missing" |
a0d0e21e |
15 | if $^W; |
16 | $pack->new(@_); |
17 | } |
18 | else { |
19 | croak "$pack doesn't define a TIEHASH method"; |
20 | } |
21 | } |
22 | |
23 | sub EXISTS { |
24 | my $pack = ref $_[0]; |
25 | croak "$pack doesn't define an EXISTS method"; |
26 | } |
27 | |
28 | sub CLEAR { |
29 | my $self = shift; |
30 | my $key = $self->FIRSTKEY(@_); |
31 | my @keys; |
32 | |
33 | while (defined $key) { |
34 | push @keys, $key; |
35 | $key = $self->NEXTKEY(@_, $key); |
36 | } |
37 | foreach $key (@keys) { |
38 | $self->DELETE(@_, $key); |
39 | } |
40 | } |
41 | |
748a9306 |
42 | # The TieHash::Std package implements standard perl hash behaviour. |
43 | # It exists to act as a base class for classes which only wish to |
44 | # alter some parts of their behaviour. |
45 | |
46 | package TieHash::Std; |
47 | @ISA = qw(TieHash); |
48 | |
49 | sub TIEHASH { bless {}, $_[0] } |
50 | sub STORE { $_[0]->{$_[1]} = $_[2] } |
51 | sub FETCH { $_[0]->{$_[1]} } |
52 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } |
53 | sub NEXTKEY { each %{$_[0]} } |
54 | sub EXISTS { exists $_[0]->{$_[1]} } |
55 | sub DELETE { delete $_[0]->{$_[1]} } |
56 | sub CLEAR { %{$_[0]} = () } |
57 | |
a0d0e21e |
58 | 1; |