lib/Module/Build/t/bundled/Tie/CPHash.pm

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