Bill, great job on the metronet perl archive. You have got it all organised pretty well (meaning I could find what I wanted quickly ;-). Any chance of adding/replacing my soundex thing 'cos the "obfuscated" version had a bug... Here's my current shar file, Thanks, Mike #!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # made 03/24/1994 00:35 UTC by Mike.Stok@meiko.concord.ma.us # Source directory /tmp_mnt/develop/sw/misc/mike/soundex # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 1677 -r--r--r-- soundex.pl # 2408 -r-xr-xr-x soundex.t # # ============= soundex.pl ============== if test -f 'soundex.pl' -a X"$1" != X"-c"; then echo 'x - skipping soundex.pl (File already exists)' else echo 'x - extracting soundex.pl (Text)' sed 's/^X//' << 'SHAR_EOF' > 'soundex.pl' && package soundex; X ;# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ ;# ;# Implementation of soundex algorithm as described by Knuth in volume ;# 3 of The Art of Computer Programming, with ideas stolen from Ian ;# Phillips . ;# ;# Mike Stok , 2 March 1994. ;# ;# Knuth's test cases are: ;# ;# Euler, Ellery -> E460 ;# Gauss, Ghosh -> G200 ;# Hilbert, Heilbronn -> H416 ;# Knuth, Kant -> K530 ;# Lloyd, Ladd -> L300 ;# Lukasiewicz, Lissajous -> L222 ;# ;# $Log: soundex.pl,v $ ;# Revision 1.2 1994/03/24 00:30:27 mike ;# Subtle bug (any excuse :-) spotted by Rich Pinder ;# in the way I handles leasing characters which were different but had ;# the same soundex code. This showed up comparing it with Oracle's ;# soundex output. ;# ;# Revision 1.1 1994/03/02 13:01:30 mike ;# Initial revision ;# ;# ;############################################################################## X ;# $soundex'noCode is used to indicate a string doesn't have a soundex ;# code, I like undef other people may want to set it to 'Z000'. X $noCode = undef; X ;# main'soundex ;# ;# usage: ;# ;# @codes = &main'soundex (@wordList); ;# $code = &main'soundex ($word); ;# ;# This strenuously avoids $[ X sub main'soundex { X local (@s, $f, $fc, $_) = @_; X X foreach (@s) X { X tr/a-z/A-Z/; X tr/A-Z//cd; X X if ($_ eq '') X { X $_ = $noCode; X } X else X { X ($f) = /^(.)/; X tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; X ($fc) = /^(.)/; X s/^$fc+//; X tr///cs; X tr/0//d; X $_ = $f . $_ . '000'; X s/^(.{4}).*/$1/; X } X } X X wantarray ? @s : shift @s; } X 1; SHAR_EOF chmod 0444 soundex.pl || echo 'restore of soundex.pl failed' Wc_c="`wc -c < 'soundex.pl'`" test 1677 -eq "$Wc_c" || echo 'soundex.pl: original size 1677, current size' "$Wc_c" fi # ============= soundex.t ============== if test -f 'soundex.t' -a X"$1" != X"-c"; then echo 'x - skipping soundex.t (File already exists)' else echo 'x - extracting soundex.t (Text)' sed 's/^X//' << 'SHAR_EOF' > 'soundex.t' && #!./perl ;# ;# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ ;# ;# test module for soundex.pl ;# ;# $Log: soundex.t,v $ ;# Revision 1.2 1994/03/24 00:30:27 mike ;# Subtle bug (any excuse :-) spotted by Rich Pinder ;# in the way I handles leasing characters which were different but had ;# the same soundex code. This showed up comparing it with Oracle's ;# soundex output. ;# ;# Revision 1.1 1994/03/02 13:03:02 mike ;# Initial revision ;# ;# X require '../lib/soundex.pl'; X $test = 0; print "1..13\n"; X while () { X chop; X next if /^\s*;?#/; X next if /^\s*$/; X X ++$test; X $bad = 0; X X if (/^eval\s+/) X { X ($try = $_) =~ s/^eval\s+//; X X eval ($try); X if ($@) X { X $bad++; X print "not ok $test\n"; X print "# eval '$try' returned $@"; X } X } X elsif (/^\(/) X { X ($in, $out) = split (':'); X X $try = "\@expect = $out; \@got = &soundex $in;"; X eval ($try); X X if (@expect != @got) X { X $bad++; X print "not ok $test\n"; X print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; X print "# expected (", join (', ', @expect), X ") got (", join (', ', @got), ")\n"; X } X else X { X while (@got) X { X $expect = shift @expect; X $got = shift @got; X X if ($expect ne $got) X { X $bad++; X print "not ok $test\n"; X print "# expected $expect, got $got\n"; X } X } X } X } X else X { X ($in, $out) = split (':'); X X $try = "\$expect = $out; \$got = &soundex ($in);"; X eval ($try); X X if ($expect ne $got) X { X $bad++; X print "not ok $test\n"; X print "# expected $expect, got $got\n"; X } X } X X print "ok $test\n" unless $bad; } X __END__ # # 1..6 # # Knuth's test cases, scalar in, scalar out # 'Euler':'E460' 'Gauss':'G200' 'Hilbert':'H416' 'Knuth':'K530' 'Lloyd':'L300' 'Lukasiewicz':'L222' # # 7..8 # # check default bad code # '2 + 2 = 4':undef undef:undef # # 9 # # check array in, array out # ('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') # # 10 # # check array with explicit undef # ('Mike', undef, 'Stok'):('M200', undef, 'S320') # # 11..12 # # check setting $soundex'noCode # eval $soundex'noCode = 'Z000'; ('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') # # 13 # # a subtle difference between me & oracle, spotted by Rich Pinder # # CZARKOWSKA:C622 SHAR_EOF chmod 0555 soundex.t || echo 'restore of soundex.t failed' Wc_c="`wc -c < 'soundex.t'`" test 2408 -eq "$Wc_c" || echo 'soundex.t: original size 2408, current size' "$Wc_c" fi exit 0 -- The "usual disclaimers" apply. | Meiko Mike Stok | 130C Baker Ave. Ext Mike.Stok@meiko.concord.ma.us | Concord, MA 01742 Meiko tel: (508) 371 0088 |