home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _1e4fd0a0d3c56dbe1cb0b71ea723277d < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.1 KB  |  125 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@activestate.com
  43.  
  44. =head1 VERSION
  45.  
  46. Version 1.21    22 Jun 1999
  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.   keys %{$s->[0]};    # reset iterator
  98.   keys %{$s->[1]};    # reset iterator
  99.   $s->[2] = 0;
  100.   $s->NEXTKEY;
  101. }
  102.  
  103. sub NEXTKEY {
  104.   my $s = shift;
  105.   my ($k, $v);
  106.   if (!$s->[2]) {
  107.     if (($k, $v) = each %{$s->[0]}) {
  108.       return $s->[0]{"$k"}[0];
  109.     }
  110.     else {
  111.       $s->[2] = 1;
  112.     }
  113.   }
  114.   return each %{$s->[1]};
  115. }
  116.  
  117. sub CLEAR {
  118.   my $s = shift;
  119.   $s->[2] = 0;
  120.   %{$s->[0]} = ();
  121.   %{$s->[1]} = ();
  122. }
  123.  
  124. 1;
  125.