こちらから頂いてきた。
#!/usr/local/bin/perl
eval {
#########################################################
# Read in the string from the form
#########################################################
if ($ENV{'REQUEST_METHOD'} eq "GET") {
$FORM_DATA = $ENV{'QUERY_STRING'};
} else {
$LENGTH = $ENV{'CONTENT_LENGTH'};
while ($LENGTH) {
$FORM_DATA .= getc(STDIN);
$LENGTH--;
}
}
#########################################################
# Split the input string into individual variables
#########################################################
foreach (split(/&/, $FORM_DATA)) {
($NAME, $VALUE) = split(/=/, $_);
$NAME =~ s/\+/ /g;
$NAME =~ s/%([0-9|A-F]{2})/pack(C,hex($1))/eg;
$VALUE =~ s/\+/ /g;
$VALUE =~ s/%([0-9|A-F]{2})/pack(C,hex($1))/eg;
# find a unique name for select boxes
$NUM ="0";
while ($FORMDATA{$NAME} ne "") {
$NUM++;
$NAME =~ s/\.([0-9]+$)|$/\.$NUM/;
}
$FORMDATA{$NAME} = $VALUE;
}
$product = $FORMDATA{"product"};
$product =~ tr/a-z/A-Z/;
$docdirname = "/ws/w1/htmldocs/shared/semi/PDF/";
$docext = "pdf";
$docurlbase = "/semi/PDF/";
$filename = "$docdirname$product.$docext";
$default = "$product.$docext";
local(@matched, @ids, $re);
# get a list of the product ids
opendir(DOCDIR, $docdirname) || die($ENV{'SCRIPT_NAME'}||$0. ": opendir(): can't open directory \"$docdirname\": $!\n");
@ids = readdir(DOCDIR);
closedir(DOCDIR);
@ids = grep(/\.$docext$/i && s/\.$docext$//i, @ids);
if(@matched == 0) {
# make a regexp of possible $product matches
$re = $product;
# look for match
@matched = grep(/$re/i, @ids);
}
if(@matched == 0) {
# make a regexp of possible $product matches
$re = join("|", omit_list(+1, $product),
omit_list(-1, $product),
miss_list(-1, $product),
transpose_list($product));
$re = '^(?:'.$re.')$';
# look for match
@matched = grep(/$re/i, @ids);
}
# sort @matched
sub sortsub {
my $ta, $tb;
($ta = $a) =~ tr/A-Z/a-z/;
($tb = $b) =~ tr/A-Z/a-z/;
$ta cmp $tb;
}
@matched = sort sortsub @matched;
# if((! -r $filename) && (@matched != 1))) {
if(@matched == 1) {
$errmsg = "The product code you entered, $product, is similar to this product: ".
join("", map("$_", @matched)).
". If this is not what you wanted, you can try another product code, or go to a product category, by selecting it below.";
} elsif(@matched > 1) {
$errmsg = "
The product code you entered, $product, is similar to these products:
".
join("", map("- $_", @matched)).
"
If none of these are what you wanted, you can try another product code, or go to a product category, by selecting it below.";
} else {
$errmsg = "
Sorry, the product code you entered does not exist. Please try another product code, or go to a product category by selecting it below.
";
}
};
###
###
$error_file = "/ws/w1/htmldocs/shared/semi/searcherror.html";
$errmsg_spot_re = "";
if($errmsg || $@) {
$errmsg = $errmsg || "the script encountered a serious problem and couldn't complete your request: $@";
print("Content-type: text/html\n\n");
open(ERROR, $error_file);
$e = join("", (
));
close(ERROR);
if($e ne '') {
$e =~ s/$errmsg_spot_re/$errmsg/g;
} else {
$e = "Serious error: $!, and $errmsg";
}
$e .= "\n";
print($e);
}
# package alink::oneoff;
sub uniq { my %H = (); grep(!$H{$_}++, @_); }
sub nonuniq { my %H = (); grep($H{$_}++ == 1, @_); }
sub omit_list {
my $e_len = shift;
my @R = ();
my $g;
foreach $g (@_) {
my $g_len = length($g);
if($e_len > 0) {
push(@R, uniq(omit_list($e_len-1, map(substr($g,0,$_).".".substr($g,$_), (0..$g_len)))));
} elsif($e_len < 0) {
push(@R, uniq(omit_list($e_len+1, map(substr($g,0,$_).substr($g,$_+1), (0..$g_len-1)))));
} else {
push(@R, $g);
}
}
@R;
}
sub miss_list {
my $e_len = shift;
my @R = ();
my $g;
foreach $g (@_) {
my $g_len = length($g);
if($e_len < 0) {
push(@R, uniq(miss_list($e_len+1, map(substr($g,0,$_).".".substr($g,$_+1), (0..$g_len-1)))));
} else {
push(@R, $g);
}
}
@R;
}
sub transpose_list {
my @R = ();
my $g;
foreach $g (@_) {
my $g_len = length($g);
push(@R, uniq(map(substr($g,0,$_-1).substr($g,$_,1).substr($g,$_-1,1).substr($g,$_+1), (1..$g_len-1))));
}
@R;
}
## examples
## fetch some words
#chop(@l = (<>));
## regexps for if one letter was omitted
#print(map($_."\n", omit_list(+1, @l)));
## regexps for if one extra letter was added
#print(map($_."\n", omit_list(-1, @l)));
## regexps for if one letter was screwed up
#print(map($_."\n", miss_list(-1, @l)));
## regexps for if two letters were transposed
#print(map($_."\n", transpose_list(@l)));
## possible matches if one letter were omitted
#print(map($_."\n", omit_list(-1, @l)));
## possible matches if two letters were transposed
#print(map($_."\n", transpose_list(@l)));
## check for possible collisions if one letter were omitted
#print(map($_."\n", nonuniq(omit_list(-1, @l))), "\n");
## check for possible collisions if two letters were transposed
#print(map($_."\n", nonuniq(transpose_list(@l))), "\n");
# end
Daily WTF!にも載るのかなこれ。
