home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / Tie / RefHash.pm < prev    next >
Text File  |  1997-11-25  |  2KB  |  124 lines
  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;
  124.