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 <ian@pipex.net>.
;#
;# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 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 <rpinder@hsc.usc.edu>
;# 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 <rpinder@hsc.usc.edu>
;# 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 (<DATA>)
{
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
# <rpinder@hsc.usc.edu>
#
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         |