contrib/perl5/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
  13     untie HASHVARIABLE;
  14
  15 =head1 DESCRIPTION
  16
  17 This module provides the ability to use references as hash keys if
  18 you first C<tie> the hash variable to this module.
  19
  20 It is implemented using the standard perl TIEHASH interface.  Please
  21 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
  22
  23 =head1 EXAMPLE
  24
  25     use Tie::RefHash;
  26     tie %h, 'Tie::RefHash';
  27     $a = [];
  28     $b = {};
  29     $c = \*main;
  30     $d = \"gunk";
  31     $e = sub { 'foo' };
  32     %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
  33     $a->[0] = 'foo';
  34     $b->{foo} = 'bar';
  35     for (keys %h) {
  36        print ref($_), "\n";
  37     }
  38
  39
  40 =head1 AUTHOR
  41
  42 Gurusamy Sarathy        gsar@umich.edu
  43
  44 =head1 VERSION
  45
  46 Version 1.2    15 Dec 1996
  47
  48 =head1 SEE ALSO
  49
  50 perl(1), perlfunc(1), perltie(1)
  51
  52 =cut
  53
  54 require 5.003_11;
  55 use Tie::Hash;
  56 @ISA = qw(Tie::Hash);
  57 use strict;
  58
  59 sub TIEHASH {
  60   my $c = shift;
  61   my $s = [];
  62   bless $s, $c;
  63   while (@_) {
  64     $s->STORE(shift, shift);
  65   }
  66   return $s;
  67 }
  68
  69 sub FETCH {
  70   my($s, $k) = @_;
  71   (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k};
  72 }
  73
  74 sub STORE {
  75   my($s, $k, $v) = @_;
  76   if (ref $k) {
  77     $s->[0]{"$k"} = [$k, $v];
  78   }
  79   else {
  80     $s->[1]{$k} = $v;
  81   }
  82   $v;
  83 }
  84
  85 sub DELETE {
  86   my($s, $k) = @_;
  87   (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k});
  88 }
  89
  90 sub EXISTS {
  91   my($s, $k) = @_;
  92   (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k});
  93 }
  94
  95 sub FIRSTKEY {
  96   my $s = shift;
  97   my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]});
  98   $s->[2] = 0;
  99   $s->NEXTKEY;
 100 }
 101
 102 sub NEXTKEY {
 103   my $s = shift;
 104   my ($k, $v);
 105   if (!$s->[2]) {
 106     if (($k, $v) = each %{$s->[0]}) {
 107       return $s->[0]{"$k"}[0];
 108     }
 109     else {
 110       $s->[2] = 1;
 111     }
 112   }
 113   return each %{$s->[1]};
 114 }
 115
 116 sub CLEAR {
 117   my $s = shift;
 118   $s->[2] = 0;
 119   %{$s->[0]} = ();
 120   %{$s->[1]} = ();
 121 }
 122
 123 1;