Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #!/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 = "<p>The product code you entered, $product, is similar to this product: ".
- join("", map("<a href=\"$docurlbase$_.$docext\">$_</a>", @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 = "<p>The product code you entered, $product, is similar to these products: <ul>".
- join("", map("<li><a href=\"$docurlbase$_.$docext\">$_</a>", @matched)).
- "</ul> <p>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 = "<p><center><H2>Sorry, the product code you entered does not exist. Please try another product code, or go to a product category by selecting it below.</H2></center>";
- }
- };
- ###
- ###
- $error_file = "/ws/w1/htmldocs/shared/semi/searcherror.html";
- $errmsg_spot_re = "<!--%ERRGOESHERE%-->";
- 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("", (<ERROR>));
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement