2011年5月5日木曜日

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

0 件のコメント:

コメントを投稿