lib/Tie/RefHash.pm

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