lib/Tie/RefHash.pm

   1 package Tie::RefHash;
   2
   3 =head1 NAME
   4
   5 Tie::RefHash - use references as hash keys
   6
   7 =head1 SYNOPSIS
   8
   9     require 5.004;
  10     use Tie::RefHash;
  11     tie HASHVARIABLE, 'Tie::RefHash', LIST;
  12     tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
  13
  14     untie HASHVARIABLE;
  15
  16 =head1 DESCRIPTION
  17
  18 This module provides the ability to use references as hash keys if you
  19 first C<tie> the hash variable to this module.  Normally, only the
  20 keys of the tied hash itself are preserved as references; to use
  21 references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
  22 included as part of Tie::Hash.
  23
  24 It is implemented using the standard perl TIEHASH interface.  Please
  25 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
  26
  27 The Nestable version works by looking for hash references being stored
  28 and converting them to tied hashes so that they too can have
  29 references as keys.  This will happen without warning whenever you
  30 store a reference to one of your own hashes in the tied hash.
  31
  32 =head1 EXAMPLE
  33
  34     use Tie::RefHash;
  35     tie %h, 'Tie::RefHash';
  36     $a = [];
  37     $b = {};
  38     $c = \*main;
  39     $d = \"gunk";
  40     $e = sub { 'foo' };
  41     %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
  42     $a->[0] = 'foo';
  43     $b->{foo} = 'bar';
  44     for (keys %h) {
  45        print ref($_), "\n";
  46     }
  47
  48     tie %h, 'Tie::RefHash::Nestable';
  49     $h{$a}->{$b} = 1;
  50     for (keys %h, keys %{$h{$a}}) {
  51        print ref($_), "\n";
  52     }
  53
  54 =head1 AUTHOR
  55
  56 Gurusamy Sarathy        gsar@activestate.com
  57
  58 =head1 VERSION
  59
  60 Version 1.21    22 Jun 1999
  61
  62 =head1 SEE ALSO
  63
  64 perl(1), perlfunc(1), perltie(1)
  65
  66 =cut
  67
  68 require 5.003_11;
  69 use Tie::Hash;
  70 @ISA = qw(Tie::Hash);
  71 use strict;
  72
  73 sub TIEHASH {
  74   my $c = shift;
  75   my $s = [];
  76   bless $s, $c;
  77   while (@_) {
  78     $s->STORE(shift, shift);
  79   }
  80   return $s;
  81 }
  82
  83 sub FETCH {
  84   my($s, $k) = @_;
  85   if (ref $k) {
  86       if (defined $s->[0]{"$k"}) {
  87         $s->[0]{"$k"}[1];
  88       }
  89       else {
  90         undef;
  91       }
  92   }
  93   else {
  94       $s->[1]{$k};
  95   }
  96 }
  97
  98 sub STORE {
  99   my($s, $k, $v) = @_;
 100   if (ref $k) {
 101     $s->[0]{"$k"} = [$k, $v];
 102   }
 103   else {
 104     $s->[1]{$k} = $v;
 105   }
 106   $v;
 107 }
 108
 109 sub DELETE {
 110   my($s, $k) = @_;
 111   (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k});
 112 }
 113
 114 sub EXISTS {
 115   my($s, $k) = @_;
 116   (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k});
 117 }
 118
 119 sub FIRSTKEY {
 120   my $s = shift;
 121   keys %{$s->[0]};      # reset iterator
 122   keys %{$s->[1]};      # reset iterator
 123   $s->[2] = 0;
 124   $s->NEXTKEY;
 125 }
 126
 127 sub NEXTKEY {
 128   my $s = shift;
 129   my ($k, $v);
 130   if (!$s->[2]) {
 131     if (($k, $v) = each %{$s->[0]}) {
 132       return $s->[0]{"$k"}[0];
 133     }
 134     else {
 135       $s->[2] = 1;
 136     }
 137   }
 138   return each %{$s->[1]};
 139 }
 140
 141 sub CLEAR {
 142   my $s = shift;
 143   $s->[2] = 0;
 144   %{$s->[0]} = ();
 145   %{$s->[1]} = ();
 146 }
 147
 148 package Tie::RefHash::Nestable;
 149 use vars '@ISA'; @ISA = qw(Tie::RefHash);
 150
 151 sub STORE {
 152   my($s, $k, $v) = @_;
 153   if (ref($v) eq 'HASH' and not tied %$v) {
 154       my @elems = %$v;
 155       tie %$v, ref($s), @elems;
 156   }
 157   $s->SUPER::STORE($k, $v);
 158 }
 159
 160 1;