/usr/share/tcltk/tcllib1.14/soundex/soundex.tcl is in tcllib 1.14-dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | # soundex.tcl --
#
# Implementation of soundex in Tcl
#
# Copyright (c) 2003 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: soundex.tcl,v 1.3 2004/01/15 06:36:14 andreas_kupries Exp $
package require Tcl 8.2
namespace eval ::soundex {}
## ------------------------------------------------------------
##
## I. Soundex by Knuth.
# This implementation of the Soundex algorithm is released to the public
# domain: anyone may use it for any purpose. See if I care.
# N. Dean Pentcheff 1/13/89 Dept. of Zoology University of California Berkeley,
# CA 94720 dean@violet.berkeley.edu
# TCL port by Evan Rempel 2/10/98 Dept Comp Services University of Victoria.
# erempel@uvic.ca
# proc ::soundex::knuth ( string )
#
# Given as argument: a character string. Returns: a static string, 4 characters long
# This string is the Soundex key for the argument string.
# Side effects and limitations:
# Does not clobber the string passed in as the argument. No limit on
# argument string length. Assumes a character set with continuously
# ascending and contiguous letters within each case and within the digits
# (e.g. this works for ASCII and bombs in EBCDIC. But then, most things
# do.). Reference: Adapted from Knuth, D.E. (1973) The art of computer
# programming; Volume 3: Sorting and searching. Addison-Wesley Publishing
# Company: Reading, Mass. Page 392.
# Special cases: Leading or embedded spaces, numerals, or punctuation are squeezed
# out before encoding begins.
#
# Null strings or those with no encodable letters return the code 'Z000'.
#
# Test data from Knuth (1973):
# Euler Gauss Hilbert Knuth Lloyd Lukasiewicz
# E460 G200 H416 K530 L300 L222
namespace eval ::soundex {
variable soundexKnuthCode
array set soundexKnuthCode {
a 0 b 1 c 2 d 3 e 0 f 1 g 2 h 0 i 0 j 2 k 2 l 4 m 5
n 5 o 0 p 1 q 2 r 6 s 2 t 3 u 0 v 1 w 0 x 2 y 0 z 2
}
}
proc ::soundex::knuth {in} {
variable soundexKnuthCode
set key ""
# Remove the leading/trailing white space punctuation etc.
set TempIn [string trim $in "\t\n\r .,'-"]
# Only use alphabetic characters, so strip out all others
# also, soundex index uses only lower case chars, so force to lower
regsub -all {[^a-z]} [string tolower $TempIn] {} TempIn
if {[string length $TempIn] == 0} {
return Z000
}
set last [string index $TempIn 0]
set key [string toupper $last]
set last $soundexKnuthCode($last)
# Scan rest of string, stop at end of string or when the key is
# full
set count 1
set MaxIndex [string length $TempIn]
for {set index 1} {(($count < 4) && ($index < $MaxIndex))} {incr index } {
set chcode $soundexKnuthCode([string index $TempIn $index])
# Fold together adjacent letters sharing the same code
if {![string equal $last $chcode]} {
set last $chcode
# Ignore code==0 letters except as separators
if {$last != 0} then {
set key $key$last
incr count
}
}
}
return [string range ${key}0000 0 3]
}
package provide soundex 1.0
|