It's a Sony!

こちらから頂いてきた。

#!/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!にも載るのかなこれ。