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