xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/lib/Tie/RefHash.pm (revision 0:68f95e015346) 
1package Tie::RefHash;
2
3our $VERSION = 1.31;
4
5=head1 NAME
6
7Tie::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
20This module provides the ability to use references as hash keys if you
21first C<tie> the hash variable to this module.  Normally, only the
22keys of the tied hash itself are preserved as references; to use
23references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
24included as part of Tie::RefHash.
25
26It is implemented using the standard perl TIEHASH interface.  Please
27see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
28
29The Nestable version works by looking for hash references being stored
30and converting them to tied hashes so that they too can have
31references as keys.  This will happen without warning whenever you
32store 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
58Gurusamy Sarathy        gsar@activestate.com
59
60'Nestable' by Ed Avis   ed@membled.com
61
62=head1 VERSION
63
64Version 1.30
65
66=head1 SEE ALSO
67
68perl(1), perlfunc(1), perltie(1)
69
70=cut
71
72use Tie::Hash;
73use vars '@ISA';
74@ISA = qw(Tie::Hash);
75use strict;
76
77require overload; # to support objects with overloaded ""
78
79sub 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
89sub 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
105sub 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
116sub DELETE {
117  my($s, $k) = @_;
118  (ref $k) ? delete($s->[0]{overload::StrVal($k)}) : delete($s->[1]{$k});
119}
120
121sub EXISTS {
122  my($s, $k) = @_;
123  (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k});
124}
125
126sub 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
134sub 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
148sub CLEAR {
149  my $s = shift;
150  $s->[2] = 0;
151  %{$s->[0]} = ();
152  %{$s->[1]} = ();
153}
154
155package Tie::RefHash::Nestable;
156use vars '@ISA';
157@ISA = 'Tie::RefHash';
158
159sub 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
1681;
169