t/lib/Tie/CPHash.pm

   1 #---------------------------------------------------------------------
   2 package Tie::CPHash;
   3 #
   4 # Copyright 1997 Christopher J. Madsen
   5 #
   6 # Author: Christopher J. Madsen <cjm@pobox.com>
   7 # Created: 08 Nov 1997
   8 # $Revision$  $Date$
   9 #
  10 # This program is free software; you can redistribute it and/or modify
  11 # it under the same terms as Perl itself.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
  16 # GNU General Public License or the Artistic License for more details.
  17 #
  18 # Case preserving but case insensitive hash
  19 #---------------------------------------------------------------------
  20
  21 require 5.000;
  22 use strict;
  23 use vars qw(@ISA $VERSION);
  24
  25 @ISA = qw();
  26
  27 #=====================================================================
  28 # Package Global Variables:
  29
  30 $VERSION = '1.02';
  31
  32 #=====================================================================
  33 # Tied Methods:
  34 #---------------------------------------------------------------------
  35 # TIEHASH classname
  36 #      The method invoked by the command `tie %hash, classname'.
  37 #      Associates a new hash instance with the specified class.
  38
  39 sub TIEHASH
  40 {
  41     bless {}, $_[0];
  42 } # end TIEHASH
  43
  44 #---------------------------------------------------------------------
  45 # STORE this, key, value
  46 #      Store datum *value* into *key* for the tied hash *this*.
  47
  48 sub STORE
  49 {
  50     $_[0]->{lc $_[1]} = [ $_[1], $_[2] ];
  51 } # end STORE
  52
  53 #---------------------------------------------------------------------
  54 # FETCH this, key
  55 #      Retrieve the datum in *key* for the tied hash *this*.
  56
  57 sub FETCH
  58 {
  59     my $v = $_[0]->{lc $_[1]};
  60     ($v ? $v->[1] : undef);
  61 } # end FETCH
  62
  63 #---------------------------------------------------------------------
  64 # FIRSTKEY this
  65 #      Return the (key, value) pair for the first key in the hash.
  66
  67 sub FIRSTKEY
  68 {
  69     my $a = scalar keys %{$_[0]};
  70     &NEXTKEY;
  71 } # end FIRSTKEY
  72
  73 #---------------------------------------------------------------------
  74 # NEXTKEY this, lastkey
  75 #      Return the next (key, value) pair for the hash.
  76
  77 sub NEXTKEY
  78 {
  79     my $v = (each %{$_[0]})[1];
  80     ($v ? $v->[0] : undef );
  81 } # end NEXTKEY
  82
  83 #---------------------------------------------------------------------
  84 # SCALAR this
  85 #     Return bucket usage information for the hash (0 if empty).
  86
  87 sub SCALAR
  88 {
  89     scalar %{$_[0]};
  90 } # end SCALAR
  91
  92 #---------------------------------------------------------------------
  93 # EXISTS this, key
  94 #     Verify that *key* exists with the tied hash *this*.
  95
  96 sub EXISTS
  97 {
  98     exists $_[0]->{lc $_[1]};
  99 } # end EXISTS
 100
 101 #---------------------------------------------------------------------
 102 # DELETE this, key
 103 #     Delete the key *key* from the tied hash *this*.
 104 #     Returns the old value, or undef if it didn't exist.
 105
 106 sub DELETE
 107 {
 108     my $v = delete $_[0]->{lc $_[1]};
 109     ($v ? $v->[1] : undef);
 110 } # end DELETE
 111
 112 #---------------------------------------------------------------------
 113 # CLEAR this
 114 #     Clear all values from the tied hash *this*.
 115
 116 sub CLEAR
 117 {
 118     %{$_[0]} = ();
 119 } # end CLEAR
 120
 121 #=====================================================================
 122 # Other Methods:
 123 #---------------------------------------------------------------------
 124 # Return the case of KEY.
 125
 126 sub key
 127 {
 128     my $v = $_[0]->{lc $_[1]};
 129     ($v ? $v->[0] : undef);
 130 }
 131
 132 #=====================================================================
 133 # Package Return Value:
 134
 135 1;
 136
 137 __END__
 138
 139 =head1 NAME
 140
 141 Tie::CPHash - Case preserving but case insensitive hash table
 142
 143 =head1 SYNOPSIS
 144
 145     require Tie::CPHash;
 146     tie %cphash, 'Tie::CPHash';
 147
 148     $cphash{'Hello World'} = 'Hi there!';
 149     printf("The key `%s' was used to store `%s'.\n",
 150            tied(%cphash)->key('HELLO WORLD'),
 151            $cphash{'HELLO world'});
 152
 153 =head1 DESCRIPTION
 154
 155 The B<Tie::CPHash> module provides a hash table that is case
 156 preserving but case insensitive.  This means that
 157
 158     $cphash{KEY}    $cphash{key}
 159     $cphash{Key}    $cphash{keY}
 160
 161 all refer to the same entry.  Also, the hash remembers which form of
 162 the key was last used to store the entry.  The C<keys> and C<each>
 163 functions will return the key that was used to set the value.
 164
 165 An example should make this clear:
 166
 167     tie %h, 'Tie::CPHash';
 168     $h{Hello} = 'World';
 169     print $h{HELLO};            # Prints 'World'
 170     print keys(%h);             # Prints 'Hello'
 171     $h{HELLO} = 'WORLD';
 172     print $h{hello};            # Prints 'WORLD'
 173     print keys(%h);             # Prints 'HELLO'
 174
 175 The additional C<key> method lets you fetch the case of a specific key:
 176
 177     # When run after the previous example, this prints 'HELLO':
 178     print tied(%h)->key('Hello');
 179
 180 (The C<tied> function returns the object that C<%h> is tied to.)
 181
 182 If you need a case insensitive hash, but don't need to preserve case,
 183 just use C<$hash{lc $key}> instead of C<$hash{$key}>.  This has a lot
 184 less overhead than B<Tie::CPHash>.
 185
 186 =head1 AUTHOR
 187
 188 Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
 189
 190 =cut
 191
 192 # Local Variables:
 193 # tmtrack-file-task: "Tie::CPHash.pm"
 194 # End: