lib/Tie/RefHash.pm

   1 package Tie::RefHash;
   2
   3 our $VERSION = 1.32;
   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.32
  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)
 119     ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1]
 120     : delete($s->[1]{$k});
 121 }
 122
 123 sub EXISTS {
 124   my($s, $k) = @_;
 125   (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k});
 126 }
 127
 128 sub FIRSTKEY {
 129   my $s = shift;
 130   keys %{$s->[0]};      # reset iterator
 131   keys %{$s->[1]};      # reset iterator
 132   $s->[2] = 0;      # flag for iteration, see NEXTKEY
 133   $s->NEXTKEY;
 134 }
 135
 136 sub NEXTKEY {
 137   my $s = shift;
 138   my ($k, $v);
 139   if (!$s->[2]) {
 140     if (($k, $v) = each %{$s->[0]}) {
 141       return $v->[0];
 142     }
 143     else {
 144       $s->[2] = 1;
 145     }
 146   }
 147   return each %{$s->[1]};
 148 }
 149
 150 sub CLEAR {
 151   my $s = shift;
 152   $s->[2] = 0;
 153   %{$s->[0]} = ();
 154   %{$s->[1]} = ();
 155 }
 156
 157 package Tie::RefHash::Nestable;
 158 use vars '@ISA';
 159 @ISA = 'Tie::RefHash';
 160
 161 sub STORE {
 162   my($s, $k, $v) = @_;
 163   if (ref($v) eq 'HASH' and not tied %$v) {
 164       my @elems = %$v;
 165       tie %$v, ref($s), @elems;
 166   }
 167   $s->SUPER::STORE($k, $v);
 168 }
 169
 170 1;