lib/TieHash.pm

   1 package TieHash;
   2 use Carp;
   3
   4 sub new {
   5     my $pkg = shift;
   6     $pkg->TIEHASH(@_);
   7 }
   8
   9 # Grandfather "new"
  10
  11 sub TIEHASH {
  12     my $pkg = shift;
  13     if (defined &{"{$pkg}::new"}) {
  14         carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"
  15             if $^W;
  16         $pkg->new(@_);
  17     }
  18     else {
  19         croak "$pkg doesn't define a TIEHASH method";
  20     }
  21 }
  22
  23 sub EXISTS {
  24     my $pkg = ref $_[0];
  25     croak "$pkg 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
  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
  58 1;