#!/usr/bin/perl

use CGI;
use File::stat;
use DB_File;
use strict;
use Digest::MD5;

require "ctime.pl";

# my $AppTitle = "Secret Project Whooping Crane";
my $AppTitle = "Legend Help Depot";
my $Root     = "/legend";
# my $Root     = "$ENV{HOME}/legend/legend";
my $HelpPath = "help/spells:help/skills:help/general:help/abilities";
my $CacheDir = "/tmp/help.cache";
my $NAcross  = 6;

my %Topics   = ();
my %Seen     = ();
my @TopicList= ();

my @HelpPath = split(":", $HelpPath);

sub mkdirFor {
	my ($file) = @_;
	my $dir;
	my @paths;

	@paths = split("/", $file);
	pop @paths;
	if ($paths[0] ne "") {
		$dir = shift @paths;
		mkdir($dir, 0755);
	}
	while ($#paths >= 0) {
		$dir = "$dir/" . $paths[0];
		mkdir($dir, 0755);
		shift @paths;
	}
}

sub rewriteFile {
	my ($file, @data) = @_;

	open (DATA, ">$file.tmp");
	print DATA @data;
	close (DATA) or return;
	unlink("$file");
	rename("$file.tmp", $file);
	sleep(5);
}

sub refreshTopicCache {
	my $dir;
	my ($topic, $alias);
	my ($s1, $s2);

	mkdirFor("$CacheDir/x");

	open(IDX, "$Root/help/help.idx") or return;
	tie %Topics, 'DB_File', "$CacheDir/_topics.db", O_CREAT|O_RDWR, 0666, $DB_BTREE or return $!;

	while (<IDX>) {
		chomp;
		next if (/^#/);
		/['"]?([^:]+)['"]?:\s+(.*)/;
		$alias = $1;
		$topic = $2;
		$alias =~ s/[^a-z ]//gi;
		$alias =~ s/^\s+//;
		$alias =~ s/\s+$//;
		$topic =~ s/^\s+//;
		$topic =~ s/\s+$//;
		next if ($alias eq "");
		$Topics{lc($alias)} = lc($topic);
	}
	close(IDX);

	for $dir (@HelpPath) {
		opendir(DIR, "$Root/$dir");
		for (grep (!/^\./, readdir(DIR))) {
			next unless (s/\.hlp$//);
			$Topics{lc($_)} = lc($_);
		}
	}

}

sub checkCache {
	my ($cache, $orig) = @_;
	my ($scache, $sorig);

	$scache = stat("$cache");
	$sorig  = stat("$orig");

	unless ($scache and $sorig) {
		return -1;
	}

	if ($scache->mtime >= $sorig->mtime) {
		## Use existing cache db
		return 1;
	}

	else {
		return -1;
	}
}

sub indexTopics {
	my $dir;
	my ($topic, $alias);

	if (checkCache("$CacheDir/_topics.db", "$Root/help/help.idx") > 0) {
		tie %Topics, 'DB_File', "$CacheDir/_topics.db", O_RDONLY,
		             0666, $DB_BTREE or return $!;
	}
	else {
		$_ = refreshTopicCache();
		return $_ if ($_);
	}

	@TopicList = sort {
		return -1 if (substr($a, 0, length($b)) eq $b);
		return  1 if (substr($b, 0, length($a)) eq $a);
		$a cmp $b;
	} keys %Topics;

	return undef;
}

sub findHelpFile {
	my ($topic) = @_;
	my ($dir);

	for my $dir (@HelpPath) {
		if (-f "$Root/$dir/$topic.hlp") {
			return "$Root/$dir/$topic.hlp";
		}
	}
	return undef;
}

sub getHelpText {
	my ($helpname, $hlpfile) = @_;
	my $found = 0;
	my @help = ();
	my $dir;

	$hlpfile = findHelpFile($helpname) unless defined($hlpfile);
	if (!defined($hlpfile)) {
		return ();
	}

	## Block access to restricted files?
	if (0) {
		$_ = $hlpfile;
		s/\.hlp$/\.res/;
		if (-f $_) {
			return ("This help file is restricted.");
		}
	}

	open(HELP, $hlpfile);
	push @help, <HELP>;
	map {chomp; s/^\s+//; s/\s+$//;} @help;
	close HELP;

	return () if ($#help < 0);

	if (open(KEY, "$Root/$dir/$helpname.key")) {
		$_ = <KEY>;
		s/^\s+//;
		s/\s+$//;
		s/\s+/, /g;
		close(KEY);
	}
	else {
		$_ = $helpname;
	}
	unshift @help, "TOPIC: " . uc($_);

	return @help;
}

sub sanitize {
	$_[0] =~ s/&/&amp;/g;
	$_[0] =~ s/</&lt;/g;
	$_[0] =~ s/>/&gt;/g;
	return $_[0];
}


sub crossLink {
	my ($in, $topic, $alias) = @_;
	my $tmp = $topic;
	# Don't need to encode topic -- javascript does this for us.
	#$tmp =~ s/([^a-z0-9])/sprintf("%%%02x", ord($1))/egi;
	# But we do need to ditch spaces.
	$tmp =~ s/\s/_/g;
	$in =~ s^([\s,.!:;"'])($alias)([\s,.!:;"'])^$1<a class="help-ref" href="#" onclick="selectItem('$tmp');">$2</a>$3^i;
	$Seen{$topic} = 1;
	return $in;
}


sub decorate {
	my ($owntopic, @in) = @_;
	my @out = ();
	my %state = ();
	my ($alias, $topic);

	for (@in) {

		s@<([^>]+)>@<\001span class="syntax-argument"\002$1\001/span\002>@g;
		$_ = sanitize($_);
		s@\001@<@g;
		s@\002@>@g;

		if (/^\s*(topic):\s+(.*)\s*$/i) {
			push @out, "<h3 class=\"topicname\">Help for $2</h3>";
			push @out, "<hr class=\"topicname\" />";
			next;
		}

		if (/^\s*(syntax|usage):\s+(.*)\s*$/i) {
			unless ($state{syntax}) {
				push @out, "<p class=\"syntax\">";
			}
			$state{syntax} = 1;

			push @out, "syntax: <span class=\"syntax\">$2</span><br/>";
			next;
		}

		if ($state{syntax}) {
			delete $state{syntax};
			push @out, "</p>";
		}

		if (/^\s*$/) {
			if ($state{para}) {
				push @out, "</p>";
			}
			push @out, "<p>";
			$state{para} = 1;
			next;
		}

		## Zero-width assertion \b here isn't really good enough, need
		## spaces.  So insert spaces at ends to simplify matching. :P
		$_ = " $_ ";	# bleh
		for $alias (@TopicList) {
			my $upper = uc($alias);
			$topic = $Topics{$alias};
			if (/[\s,.!:;"']$alias[\s,.!:;"']/i
			    and !exists($Seen{$topic})
			    and !/<[^>]*\s$alias\s.*>/i
			    and ($topic ne $Topics{$owntopic})) {
				$_ = crossLink($_, $topic, $alias);
			}

			## ALWAYS crosslink HELP FOO
			elsif (/HELP $upper/) {
				$_ = crossLink($_, $topic, $alias);
			}
		}

		$_ =~ s/^ (.*) $/$1/;

		## If short and ends in a colon, consider it a headline.
		if (/:\s*$/ && length($_) < 50) {
			$_ = "<span class=\"headline\">$_</span><br/>";
		}

		## If multiple sequences of doubled whitespace, consider
		## it block text.
		elsif (/\s{2}\S.*\s{2}/) {
			$_ = "<span class=\"blocktext\">$_</span><br/>";
		}

		## If colon delimiting, consider preformatted but without
		## fixed font.
		elsif (/\s:\s/) {
			$_ = "<span class=\"keyvalue\">$_</span><br/>";
		}

		push @out, $_;
	}

	pop @out if ($out[$#out] eq "<p>");
	return @out;
}

sub getHelpHTML {
	my ($topic) = @_;
	my $hlpfile;
	my $htmlfile;
	my @help;
	my @html;
	my $status;

	## first value returned is:
	##    1 if cached
	##    0 if stale and refreshed
	##   -1 if not cached

	$topic = $Topics{$topic};
	$hlpfile = findHelpFile("$topic");
	$htmlfile = "$CacheDir/$topic.html";
	$htmlfile =~ s/\s/_/g;

	$status = checkCache($htmlfile, $hlpfile);
	if ($status > 0) {
		open(HTML, $htmlfile);
		@help = <HTML>;
		close(HTML);
		return ($status, @help);
	}

	@help = getHelpText($topic, $hlpfile);
	if ($#help < 0) {
		return ($status);
	}

	@html = map {"$_\n";} decorate(lc($_), @help);
	rewriteFile($htmlfile, @html);
	return ($status, @html);
}

sub mainPage {
	my @out = ();

	push @out, <<HTML;
	<h1 class="pagetitle">$AppTitle</h1>
	<p class="bodytext">
		<!-- Choose your poison: -->
	</p>
	<div class="helptext" id="helpbox">
	</div>

	<div class="status" id="status">
	</div>

	<div class="topiclist" id="topiclist">
	</div>

HTML
	#<ul class="helplist">

	push @out, <<HTML;
HTML
	#</ul>

	return @out;
}

sub htmlForTopics {
	my @topics = @_;
	my @html;
	my $n = 0;

	push @html, '<table cellpadding="1" cellspacing="1" border="0">';
	push @html, "	<tr>";
	for (@topics) {
		#push @html, "		<li class=\"helpitem\">$_</li>";
		if ((++$n % $NAcross) == 0) {
			push @html, "	</tr>";
			push @html, "	<tr>";
		}
		push @html, "		<td class=\"helpitem\"><a class=\"help-topic\" href=\"#\" onclick=\"selectItem('$_')\">$_</a></td>";
	}
	push @html, "	</tr>";
	push @html, "</table>";

	return @html;
}

sub genTopicList {
	my @out;
	my %initials = ();
	my $initial;

	push @out, '<h2 class="section">Topic List</h2>';
	push @out, '<center>';

	for (@TopicList) {
		$initials{lc(substr($_, 0, 1))} = 1;
	}

	for $initial (sort keys %initials) {
		#$initial = uc($initial);
		push @out, "<a class=\"topiclink\" href=\"#\" onclick=\"selectTopicGroup('$initial');\">" . uc($initial) . "</a>";
	}
	push @out, "<br/>";
	push @out, "<a class=\"topiclink\" href=\"#\" onclick=\"selectTopicGroup('search');\">search</a>";

	for $initial (sort keys %initials) {
		#$initial = uc($initial);
		push @out, "<div class=\"topicgroup\" id=\"tgroup_$initial\">";
		push @out, '<h2 class="tgrouptitle">' . uc($initial) . '</h2>';
		push @out, htmlForTopics(sort grep /^$initial/i, @TopicList);
		push @out, "</div>";
	}

	push @out, '<div class="topicgroup" id="tgroup_search">';
	push @out, '<h2 class="tgrouptitle">Search</h2>';
	push @out, '<form name="dummyForm" onSubmit="return searchTrigger();">';
	push @out, '<input type="text" name="topicSearch" id="topicSearch" value="" size="40" onFocus="setCaptureKeys(false);focusInput();" onBlur="setCaptureKeys(true);"/>';
	push @out, '</form>';
	push @out, '<div class="searchresults" id="searchResults">';
	push @out, '</div>';
	push @out, '</div>';

	push @out, "<p>&nbsp;</p>";

	push @out, '</center>';

	return @out;
}

sub getTopicList {
	my @html;
	my $md5 = new Digest::MD5;
	my $t;

	if (checkCache("$CacheDir/_topics.html", "$CacheDir/_topics.db") > 0) {
		## use cached HTML
		open(HTML, "$CacheDir/_topics.html");
		@html = <HTML>;
		close(HTML);
		my $s = stat("$CacheDir/_topics.html");
		$t = $s->mtime;
	}

	else {
		@html = map {"$_\n";} genTopicList();
		rewriteFile("$CacheDir/_topics.html", @html);
		$t = time();
	}

	$md5->add(@html);
	return ($t, $md5->hexdigest, @html);
}

sub searchTopicList {
	my ($search) = @_;
	my @matches;
	my @html;

	@html = ("Search results for \"$search\":");
	@matches = grep /\b$search/io, @TopicList;
	push @html, htmlForTopics(sort @matches);

	if ($#matches == 0) {
		push @html, "<exactMatch keyName=\"$matches[0]\" />";
	}
	elsif (exists($Topics{lc($search)})) {
		push @html, "<span exactMatch=\"$search\"></span>";
	}

	return map {"$_\n";} @html;
}

sub cgiMode {
	my ($err) = @_;

	my $cgi = new CGI;

	## Given query params, operate as an AJAX back-end.  Do not
	## emit complete document.
	if ($_ = $cgi->param("topic")) {
		my ($status, @help) = getHelpHTML(lc($_));

		print $cgi->header;

		if ($#help < 0) {
			print "No help found for \"$_\".\n";
		}
		else {
			print @help;
		}
		untie (%Topics);
		exit 0;
	}

	if ($cgi->param("topiclist")) {

		my ($t, $md5, @html) = getTopicList();

		my $ct = ctime($t);
		chomp $ct;
		print $cgi->header(-etag => $md5, "-last-modified" => $ct);

		print @html;
		untie (%Topics);
		exit 0;
	}

	if ($_ = $cgi->param("topicSearch")) {
		print $cgi->header;

		print searchTopicList($_);
		untie (%Topics);
		exit 0;
	}

	$_ = $cgi->param("startTopic");

	print $cgi->header;

	print $cgi->start_html(
		-title      => "$AppTitle",
		-style      => { -src => 'help.css' },
		-script     => { -src => 'help.js' },
		-onLoad     => "loader(\"$_\")",
	);

	if ($err) {
		print "<span class=\"error\">$err</span>\n";
	}

	else {
		print mainPage();
	}

	print $cgi->end_html;
}

sub cliMode {
	my ($err) = @_;
	my %uniq;
	my @vals;

	if ($ARGV[0] eq "-precache") {
		for (values %Topics) {
			$uniq{$_} = $_;
		}
		@vals = sort keys %uniq;
		print $#vals + 1, " topics to precache.\n";
		for (@vals) {
			$_ = lc($_);
			print "Precaching \"$_\"... ";

			## Erase %Seen on each pass.
			%Seen = ();

			my ($status, @html) = getHelpHTML($_);
			print "already cached.\n" if ($status > 0);
			print "refreshed.\n" if ($status == 0);
			print "precached.\n" if ($status < 0);
		}
		print "Precached ", $#vals+1, " topics.\n";
		exit 0;
	}
}

sub main {
	my $err = indexTopics();

	if ($ARGV[0] =~ /^-/) {
		cliMode($err);
	}
	else {
		cgiMode($err);
	}

	untie (%Topics);
	exit 0;
}

main();