#!/usr/bin/perl -w

# Configuration section
$contentNegotiation = 1;
# End configuration section

#use locale;
use DirHandle;

sub uriEscape {
    my $in = $_[0];
    my $out = "";

    my $i = 0;
    while ($i < length($in)) {
	my $ch = substr($in, $i, 1);
	if ($ch =~ m,[-A-Za-z0-9:/.],) {
	    $out .= $ch;
	} else {
	    $out .= sprintf("%%%02x", ord($ch));
	}
	$i++;
    }
    return $out;
}

sub htmlEscape {
    my $in = $_[0];
    my $out = "";

    my $i = 0;
    while ($i < length($in)) {
	my $ch = substr($in, $i, 1);
	if ($ch =~ m,[-A-Za-z0-9:/ .],) {
	    $out .= $ch;
	} else {
	    $out .= sprintf("&#%d;", ord($ch));
	}
	$i++;
    }
    return $out;
}

# Phase 1:  Try to find a matching URL first
# Phase 1a: Is it a directory, try without final /
#           Will not result in a loop, as it will no longer match this
#           rule after one pass. Also, it is unlikely, that a normal
#           process could result with this (.asis redirect should not
#           be possible; automatic redirect upon finding a directory
#           should then return "Permission denied" without index)

my $string = $ENV{"REQUEST_URI"};
if ($string =~ m,^/.*/$,) {
    # Remove trailing slashes
    $string =~ s,/*$,,;
    # Create redirect
    print "Status: 302 Try this instead\r\n";
    print "Location: http://" . $ENV{"HTTP_HOST"} . $string . "\r\n\r\n";
    exit 0;
}

# Do minimal language negotiation for the following steps
# Recognized languages:
my $langs = "_en_de_";
my $lang = undef;
my $language = $ENV{"HTTP_ACCEPT_LANGUAGE"};
if (defined($language)) {
    @languages = split(/,\s*/, $language);
    foreach $l (@languages) {
    	$l =~ tr/A-Z/a-z/;
    	$l =~ s/_.*//;
        if (!defined($lang) && $langs =~ /_\$l_/) {
	   $lang = $l;
	}
    }
}
$lang = "en" unless defined($lang);

# Minimal localization
my %notFound     = ( en => "Not Found", de => "Nicht gefunden" );
my %search       = ( en => "Search ", de => "Suchen nur auf " );
my %searchWWW    = ( en => "Search WWW", de => "Durchsuchen des WWW" );
my %googleSearch = ( en => "Google Search", de => "Google-Suche" );
my %instr        = ( en => '<p>The requested URL was not found on this server.
You can try to locate the document by <a href="/">manually navigating through
this site</a> or search for the document using Google:</p>',
                  de => '<p>Die gew&uuml;nschte URL konnte auf diesem Server nicht gefunden werden.
Sie k&ouml;nnen selbst <a href="/">durch diesen Server navigieren</a> oder
das Dokument mittels Google suchen:</p>' );
my %multiple     = ( en => "Multiple Choices", de => "Auswahl" );
my %multExplan1  = ( en => "<p>The document you requested (<code>",
		     de => "<p>Das Dokument, welches Sie verlangten (<code>" );
my %multExplan2  = ( en => "</code>) could not be found on this server. However,
we found documents with names similar to the one you requested.</p>

<p>Available documents:</p>
<ul>
",                   de => "</code>), konnte auf diesem Server nicht gefunden werden.
Jedoch haben wir Dokumente mit &auml;hnlichen Namen gefunden.</p>

<p>Diese sind:</p>
<ul>
" );

# Phase 1b: Try to find the appropriate (tail) name, but considering content negotiation

if ($contentNegotiation) {
my $webDir = $ENV{"SCRIPT_URL"};
$webDir =~ s,/[^/]*$,,;
my $dir = $ENV{"DOCUMENT_ROOT"} . $webDir;
my $typo = lc($ENV{"SCRIPT_URL"});
$typo =~ s,.*/,,;
$typoLen = length($typo);

my $dh = new DirHandle($dir);
my @dirEntries = $dh->read();
# No longer need to check for matches without content negotiation, this was done by mod_speling
my %matchesCN = ();
foreach my $fileEntry (@dirEntries )
{
    my $len = length($fileEntry);
    if ($len + 1 >= $typoLen && -r $dir . "/" . $fileEntry) {
	# Different length would not allow for a match, even with CN

	# Here, we do not differentiate between the different match types

	# Find first differing char
	my $i = 0;
	while ($i < $typoLen
	       && substr($typo, $i, 1) eq lc(substr($fileEntry, $i, 1))) {
	    $i++;
	}
	if ($i == $typoLen && substr($fileEntry, $i, 1) eq ".") {
	    # Test 1: Case-insensitive match
	    $matchesCN{substr($fileEntry, 0, $typoLen)} = 1;
	} elsif ($i+1 < $typoLen
		 && substr($typo, $i,   1)    eq lc(substr($fileEntry, $i+1, 1))
		 && substr($typo, $i+1, 1)    eq lc(substr($fileEntry, $i,   1))
		 && substr($typo, $i+2) . "." eq lc(substr($fileEntry, $i+2, $typoLen-$i-1))) {
	    # Test 2: Transposition
	    $matchesCN{substr($fileEntry, 0, $typoLen)} = 2;
	} elsif ($i < $typoLen
		 && substr($typo, $i+1) . "." eq lc(substr($fileEntry, $i+1, $typoLen-$i  ))) {
	    # Test 3: Simple typo
	    $matchesCN{substr($fileEntry, 0, $typoLen)} = 3;
	} elsif ($i < $typoLen
		 && substr($typo, $i+1) . "." eq lc(substr($fileEntry, $i,   $typoLen-$i  ))) {
	    # Test 4: Insertion (in typo URL)
	    $matchesCN{substr($fileEntry, 0, $typoLen-1)} = 4;
	} elsif ($i <= $typoLen
		 && substr($typo, $i  ) . "." eq lc(substr($fileEntry, $i+1, $typoLen-$i+1))) {
	    # Test 5: Deletion (in typo URL)
	    $matchesCN{substr($fileEntry, 0, $typoLen+1)} = 5;
	}
    }
}
# Do not rely on the reason; the reason stored is the one of the last file that came close enough,
# not of the closest file
if (keys(%matchesCN) == 1) {
    # Single match, simple redirect
    print "Status: 302 Try this instead\r\n";
    print "Location: http://" . $ENV{"HTTP_HOST"} . $webDir . "/" .
        join("", keys(%matchesCN)) . "\r\n\r\n";
    exit 0;
} elsif (keys(%matchesCN) > 1) {
    # Multiple matches, choice
    print 'Status: 300 Multiple close matches
Content-Type: text/html

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html lang="', $lang, '">
<head>
<title>300 ', $multiple{$lang}, '</title>
<link rel="stylesheet" href="http://www.wanda.ch/wanda.css" type="text/css" />
</head>
<body bgcolor="#fff0c0" text="#000000" link="#601010" vlink="#300060" alink="#202020">

<!-- BEGIN PLANTER PREFIX -->
<!-- END PLANTER PREFIX -->
<!-- BEGIN PLANTER NAVIGATION -->
<!-- END PLANTER NAVIGATION -->

<h1>300 ', $multiple{$lang}, '</h1>
',
	$multExplan1{$lang},
	htmlEscape("http://" . $ENV{"HTTP_HOST"} . $ENV{"REQUEST_URI"}),
        $multExplan2{$lang};
    my $prefix = "http://" . $ENV{"HTTP_HOST"} . $webDir . "/";
    foreach my $name (sort(keys(%matchesCN))) {
	print '<li><a href="', uriEscape($prefix . $name),
	    '">', htmlEscape($prefix . $name), "</a></li>\n";
    }
    print "</ul></body></html>\n";
    exit 0;
}
} # if contentNegotiation

# Phase 2: Everything else failed, offer search dialog

# Warning: REQUEST_URI can contain ".."; SCRIPT_URL has them resolved already
$string = $ENV{"REQUEST_URI"};
$string =~ s/\.[a-z]*$//;	# Remove file extension, if any
$string =~ tr/a-zA-Z/ /cs;	# Remove non-word characters
$string =~ s/^ //;		# Remove leading space, if any

my $domain = $ENV{"HTTP_HOST"};
$domain =~ s/\.$//;		# Remove trailing dot, if any
$domain =~ s/.*\.([^.]*\.[^.]*)$/$1/;	# Keep last two elements

print 'Content-type: text/html
Language: ', $lang, '
Status: 404 Not Found

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html lang="', $lang, '">
<head>
<title>404 ', $notFound{$lang}, '</title>
<link rel="stylesheet" href="http://www.wanda.ch/wanda.css" type="text/css" />
</head>
<body bgcolor="#fff0c0" text="#000000" link="#601010" vlink="#300060" alink="#202020">

<!-- BEGIN PLANTER PREFIX -->
<!-- END PLANTER PREFIX -->
<!-- BEGIN PLANTER NAVIGATION -->
<!-- END PLANTER NAVIGATION -->

<h1>404 ', $notFound{$lang}, '</h1>
';

print $instr{$lang};

print '
<form method="get" action="http://www.google.com/custom">
<table bgcolor="#FFFFFF">
<tr><td><a href="http://www.google.com/search"><img src="http://www.google.com/logos/Logo_40wht.gif" alt="Google" align="middle"></a></td>
<td>
<input type="text" name="q" size="31" maxlength="255" value="' . $string . '" />
<input type="submit" name="sa" value="', $googleSearch{$lang}, '" />
<input type="hidden" name="domains" value="' . $domain . '" /><br />
<input type="radio" name="sitesearch" value="" />', $searchWWW{$lang}, ' &nbsp;
<input type="radio" name="sitesearch" value="' . $domain . '" checked="checked" />', $search{$lang} . $domain . '<br />
</td></tr></table>
</form>

<!-- BEGIN PLANTER SUFFIX -->
<!-- END PLANTER SUFFIX -->';

if (0) {
    foreach $key (sort(keys(%ENV))) {
        print $key . " = " . $ENV{$key} . "<br />";
    }
}

print '
</body>
</html>';