[Summary view] [Print] [Text view]

   1  # Package to implement hash with case-insensitive keys.
   2  
   3  package Unattend::FoldHash;
   4  
   5  use warnings;
   6  use strict;
   7  use Carp;
   8  
   9  require Tie::Hash;
  10  
  11  # For some reason, "use fields" causes Perl 5.8.3 to warn about the
  12  # deprecated use of pseudo-hashes.  Work around this bug by using
  13  # constants and array accesses.
  14  
  15  use constant HASH => 0;
  16  use constant DNAMES => 1;
  17  use constant FOLD => 2;
  18  
  19  sub TIEHASH {
  20      my ($class, $fold) = @_;
  21      # Default folding scheme is to convert to lower-case
  22      defined $fold
  23          or $fold = sub { lc $_[0] };
  24      my $self = [ ];
  25      my %hash;
  26      tie %hash, 'Tie::StdHash';
  27      $self->[HASH] = tied %hash;
  28      $self->[DNAMES] = { };
  29      $self->[FOLD] = $fold;
  30      return bless $self, $class;
  31  }
  32  
  33  # Return display name for a key.
  34  sub _dname ($$) {
  35      my ($self, $canon_key) = @_;
  36      
  37      return (defined $canon_key
  38              ? $self->[DNAMES]->{$canon_key}
  39              : undef);
  40  }
  41  
  42  sub FETCH {
  43      my ($self, $key) = @_;
  44      my $canon_key = $self->[FOLD] ($key);
  45  
  46      return $self->[HASH]->FETCH ($canon_key);
  47  }
  48  
  49  sub STORE {
  50      my ($self, $key, $value) = @_;
  51      my $canon_key = $self->[FOLD] ($key);
  52  
  53      # Since this is a store, record the display name.
  54      $self->[DNAMES]->{$canon_key} = $key;
  55      return $self->[HASH]->STORE ($canon_key, $value);
  56  }
  57  
  58  sub DELETE {
  59      my ($self, $key) = @_;
  60      my $canon_key = $self->[FOLD] ($key);
  61      return $self->[HASH]->DELETE ($canon_key);
  62  }
  63  
  64  sub CLEAR {
  65      my ($self) = @_;
  66      $self->[DNAMES] = { };
  67      return $self->[HASH]->CLEAR ();
  68  }
  69  
  70  sub EXISTS {
  71      my ($self, $key) = @_;
  72      my $canon_key = $self->[FOLD] ($key);
  73      return $self->[HASH]->EXISTS ($canon_key);
  74  }
  75  
  76  sub FIRSTKEY {
  77      my ($self) = @_;
  78      my $canon_key = $self->[HASH]->FIRSTKEY ();
  79  
  80      # Return the key's display name.
  81      return $self->_dname ($canon_key);
  82  }
  83  
  84  sub NEXTKEY {
  85      my ($self, $lastkey) = @_;
  86      my $canon_lastkey = $self->[FOLD] ($lastkey);
  87  
  88      my $canon_key = $self->[HASH]->NEXTKEY ($canon_lastkey);
  89  
  90      # Return the key's display name.
  91      return $self->_dname ($canon_key);
  92  }
  93  
  94  # These do not appear to be necessary.
  95  #sub UNTIE { }
  96  #sub DESTROY { }
  97  
  98  
  99  ## "Nested" variant, which handles autovification.  Code shamelessly
 100  ## stolen from Tie::RefHash::Nestable.
 101  package Unattend::FoldHash::Nestable;
 102  use base qw(Unattend::FoldHash);
 103  
 104  sub STORE {
 105      my ($self, $key, $value) = @_;
 106  
 107      if (ref($value) eq 'HASH' and not tied %$value) {
 108          my @elems = %$value;
 109          tie %$value, ref $self;
 110          %$value = @elems;
 111      }
 112  
 113      return $self->SUPER::STORE ($key, $value);
 114  }
 115  
 116  1;