home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #3 / NN_1993_3.iso / spool / comp / lang / perl / 7917 next >
Encoding:
Internet Message Format  |  1993-01-21  |  2.3 KB
  1. Path: sparky!uunet!usc!sdd.hp.com!nigel.msen.com!fmsrl7!lynx.unm.edu!mimbres.cs.unm.edu!bbx!tantalum!edsr!bjk
  2. From: bjk@edsr.eds.com (Brian Kodl)
  3. Newsgroups: comp.lang.perl
  4. Subject: Re: SOUNDEX pattern matching
  5. Summary: perl library module
  6. Keywords: soundex, perl
  7. Message-ID: <1452@ares.edsr.eds.com>
  8. Date: 20 Jan 93 18:58:39 GMT
  9. References: <1jfjejINNm1q@fernwood.mpk.ca.us>
  10. Organization: EDS Research, Dallas, TX 75230
  11. Lines: 61
  12.  
  13.  
  14. Here is a perl required file containing a soundex routine that 
  15. was originally posted towards the beginning of last year. It has 
  16. been altered slightly up by Don Krause, a colleague, and myself.
  17.  
  18. Standard disclaimer: use at your own risk, we are not to be held
  19.   responsible for the actions of the code, blah, blah, blah... :-)
  20.  
  21. ----- cut here -------
  22.  
  23. # soundex.pl
  24. # by George Armhold <armhold@dimacs.rutgers.edu>
  25. # 3/22/92
  26.  
  27. # return the Soundex value of a string using the following rules:
  28. #
  29. #   1) remove W and H
  30. #   2) recode characters per table:
  31. #           A E I O U Y             0
  32. #           B F P V                 1
  33. #           C G J K Q S X Z         2
  34. #           D T                     3
  35. #           L                       4
  36. #           M N                     5
  37. #           R                       6
  38. #
  39. #   3) remove all vowels except in the first position (A E I O U Y)
  40. #   4) if two adjacent digits are now identical, remove one
  41. #   5) truncate to eight digits or pad out the result with zeroes to
  42. #   make eight digits  
  43. #   6) replace the first digit with the first character from the
  44. #   original word 
  45.  
  46. sub soundex {
  47. # takes a string as an argument, and returns its soundex value
  48.  
  49.     local($pattern) = @_;
  50.  
  51.     # upper-case the pattern to normalize matches
  52.     $pattern =~ tr/a-z/A-Z/;
  53.  
  54.     # save first char
  55.     local($first) = substr($pattern, 0, 1);
  56.  
  57.     # remove all but alphanumerics, and H,W
  58.     $pattern =~ tr/A-GI-VX-Z0-9//cd;
  59.  
  60.     # replaces letters with numbers and squish identical numbers
  61.     $pattern =~ tr/BFPVCGJKQSXZDTLMNR0-9/1111222222223345560-9/ds;
  62.  
  63.     # remove all vowels after 1st letter
  64.     substr($pattern, 1, length($pattern)) =~ tr/AEIOUY//d;
  65.    
  66.     # replace first letter
  67.     substr($pattern, 0, 1) = $first;
  68.  
  69.     # pad on zeroes if necessary and truncate
  70.     substr($pattern."00000000", 0, 8); 
  71. }
  72.  
  73. 1;                              # because this is a require'd file
  74.