lib/Text/Soundex.pm

   1 package Text::Soundex;
   2 require 5.000;
   3 require Exporter;
   4
   5 @ISA = qw(Exporter);
   6 @EXPORT = qw(&soundex $soundex_nocode);
   7
   8 $VERSION = '1.01';
   9
  10 # $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $
  11 #
  12 # Implementation of soundex algorithm as described by Knuth in volume
  13 # 3 of The Art of Computer Programming, with ideas stolen from Ian
  14 # Phillipps <ian@pipex.net>.
  15 #
  16 # Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994.
  17 #
  18 # Knuth's test cases are:
  19 #
  20 # Euler, Ellery -> E460
  21 # Gauss, Ghosh -> G200
  22 # Hilbert, Heilbronn -> H416
  23 # Knuth, Kant -> K530
  24 # Lloyd, Ladd -> L300
  25 # Lukasiewicz, Lissajous -> L222
  26 #
  27 # $Log: soundex.pl,v $
  28 # Revision 1.2  1994/03/24  00:30:27  mike
  29 # Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
  30 # in the way I handles leasing characters which were different but had
  31 # the same soundex code.  This showed up comparing it with Oracle's
  32 # soundex output.
  33 #
  34 # Revision 1.1  1994/03/02  13:01:30  mike
  35 # Initial revision
  36 #
  37 #
  38 ##############################################################################
  39
  40 # $soundex_nocode is used to indicate a string doesn't have a soundex
  41 # code, I like undef other people may want to set it to 'Z000'.
  42
  43 $soundex_nocode = undef;
  44
  45 sub soundex
  46 {
  47   local (@s, $f, $fc, $_) = @_;
  48
  49   push @s, '' unless @s;        # handle no args as a single empty string
  50
  51   foreach (@s)
  52   {
  53     $_ = uc $_;
  54     tr/A-Z//cd;
  55
  56     if ($_ eq '')
  57     {
  58       $_ = $soundex_nocode;
  59     }
  60     else
  61     {
  62       ($f) = /^(.)/;
  63       tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
  64       ($fc) = /^(.)/;
  65       s/^$fc+//;
  66       tr///cs;
  67       tr/0//d;
  68       $_ = $f . $_ . '000';
  69       s/^(.{4}).*/$1/;
  70     }
  71   }
  72
  73   wantarray ? @s : shift @s;
  74 }
  75
  76 1;
  77
  78 __END__
  79
  80 =head1 NAME
  81
  82 Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth
  83
  84 =head1 SYNOPSIS
  85
  86   use Text::Soundex;
  87
  88   $code = soundex $string;            # get soundex code for a string
  89   @codes = soundex @list;             # get list of codes for list of strings
  90
  91   # set value to be returned for strings without soundex code
  92
  93   $soundex_nocode = 'Z000';
  94
  95 =head1 DESCRIPTION
  96
  97 This module implements the soundex algorithm as described by Donald Knuth
  98 in Volume 3 of B<The Art of Computer Programming>.  The algorithm is
  99 intended to hash words (in particular surnames) into a small space using a
 100 simple model which approximates the sound of the word when spoken by an English
 101 speaker.  Each word is reduced to a four character string, the first
 102 character being an upper case letter and the remaining three being digits.
 103
 104 If there is no soundex code representation for a string then the value of
 105 C<$soundex_nocode> is returned.  This is initially set to C<undef>, but
 106 many people seem to prefer an I<unlikely> value like C<Z000>
 107 (how unlikely this is depends on the data set being dealt with.)  Any value
 108 can be assigned to C<$soundex_nocode>.
 109
 110 In scalar context C<soundex> returns the soundex code of its first
 111 argument, and in list context a list is returned in which each element is the
 112 soundex code for the corresponding argument passed to C<soundex> e.g.
 113
 114   @codes = soundex qw(Mike Stok);
 115
 116 leaves C<@codes> containing C<('M200', 'S320')>.
 117
 118 =head1 EXAMPLES
 119
 120 Knuth's examples of various names and the soundex codes they map to
 121 are listed below:
 122
 123   Euler, Ellery -> E460
 124   Gauss, Ghosh -> G200
 125   Hilbert, Heilbronn -> H416
 126   Knuth, Kant -> K530
 127   Lloyd, Ladd -> L300
 128   Lukasiewicz, Lissajous -> L222
 129
 130 so:
 131
 132   $code = soundex 'Knuth';              # $code contains 'K530'
 133   @list = soundex qw(Lloyd Gauss);      # @list contains 'L300', 'G200'
 134
 135 =head1 LIMITATIONS
 136
 137 As the soundex algorithm was originally used a B<long> time ago in the US
 138 it considers only the English alphabet and pronunciation.
 139
 140 As it is mapping a large space (arbitrary length strings) onto a small
 141 space (single letter plus 3 digits) no inference can be made about the
 142 similarity of two strings which end up with the same soundex code.  For
 143 example, both C<Hilbert> and C<Heilbronn> end up with a soundex code
 144 of C<H416>.
 145
 146 =head1 AUTHOR
 147
 148 This code was implemented by Mike Stok (C<stok@cybercom.net>) from the
 149 description given by Knuth.  Ian Phillipps (C<ian@pipex.net>) and Rich Pinder
 150 (C<rpinder@hsc.usc.edu>) supplied ideas and spotted mistakes.