home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Soundex.pm < prev    next >
Text File  |  2005-01-27  |  4KB  |  151 lines
  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.
  151.