# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use strict;

# hash of categories. value is a hash of the following structure:
# NAME => category name
# FULLNAME => fully qualified category name
# TITLE => category title (human-readable name)
# PAR => reference to parent category
# CHILDS => hash of child categories
# CHILDO => array containing names in correct order
# OBJS => array of objects in this category
my %cats;
$cats{CHILDO}=[];

# object structure is:
# NAME => object name
# FULLNAME => fully qualified object name
# TYPE => {n|c|f|d|p|s|e} type of object (namespace, class, function, data (var or const), property, struct, enum)
# USED => true if this object was explicitly documented
# DEC => declaration, if given
# BODY => object help body
# AT => "FILE(line)" indication of where this item was described
# CAT => reference to containing category
# PAR => reference to parent object
# CHILDS => children objects
# CHILDO => array of children object names, in order
my %objs;
$objs{CHILDO}=[];

# directory in which we will write html files. contains trailing slash. defaults to "./"
my $outdir;

# current file and line number
my $curfile;
my $curline;

# are we currently writing multiple files?
my $domult;

# hash of options
# GENSINGLE => generate a single, large file
# GENMULTI => generate one file per category
# RECURSE => recurse into subdirectories
# PROJNAME => project name
# VERBOSE => verbose output level

my %opts;

# utter a warning
sub utter
{
	warn "$curfile($curline): ", @_;
}

sub dump_hash($)
{
	local $_;
	my $hr = shift;
	print "Dumping hash ($hr):\n";
	for(keys %$hr) { print "$_\t=> $$hr{$_}\n"; }
	print "\n";
}

# parse categories
sub parse_cats($;$)
{
	local $_;
	my ($str, $pref, $lref, $i, $j, $nest) = @_;
	my @lst = split /\n/, $str;

	if(not $pref) { $pref=\%cats; }
	$lref = \%cats;
	
	for($i=0; $i<scalar(@lst); $i++) {
		if($lst[$i] =~ /^\s*\{/) {
			$j=++$i, $nest=1;
			while($i<scalar(@lst)) {
				if($lst[$i] =~ /^\s*\{/) { $nest++; }
				elsif($lst[$i] =~ /^\s*\}/ && !--$nest) { last; }
				$i++;
			}
			if($i == scalar(@lst)) { utter "Unbalanced braces in category ", ($$pref{FULLNAME} ? $$pref{FULLNAME} : "*root*"), "\n"; }
			else { parse_cats(join("\n", @lst[$j..$i-1]), $lref); }
		}
		elsif($lst[$i] =~ /\S/) {
			if($lst[$i] !~ /^\s*[\w:]+\s*=\s*\S/) { utter "Illegal category definition: '$lst[$i]'\n"; next; }
			my ($name, $desc) = $lst[$i]=~/^\s*([\w:]+?)\s*=\s*(.*?)\s*$/;
			$lref = add_cat(!$$pref{FULLNAME} || $name =~ /::/ ? $name : $$pref{FULLNAME}.'::'.$name);
			$$lref{TITLE}=$desc;
		}
	}
}

# add a category, given a full name, or return it if it already exists
sub add_cat($)
{
	local $_;
	my $cref = \%cats;
	if($opts{VERBOSE}>1) { print "add_cat($_[0])\n"; }
	for(split /::/, shift) {
		if($$cref{CHILDS}{$_}) { $cref=$$cref{CHILDS}{$_}; }
		else {
			my %cat;
			$$cref{CHILDS}{$_}=\%cat;
			push @{$$cref{CHILDO}}, $_;
			$cat{NAME}=$_, $cat{CHILDO}=[], $cat{PAR}=$cref, $cat{FULLNAME}=$$cref{FULLNAME} ? $$cref{FULLNAME}.'::'.$_ : $_;
			$cref=\%cat;
		}
	}
	return $cref;
}

# add an object, adding its category and object items
sub add_object($$)
{
	local $_;
	my ($oref, $cref) = (\%objs);

	if($opts{VERBOSE}>1) { print "add_object($_[0], $_[1])\n"; }
	$cref = add_cat(shift);

	for(split /::/, shift) {
		if($$oref{CHILDS}{$_}) { $oref=$$oref{CHILDS}{$_}; }
		else {
			my %obj;
			$$oref{CHILDS}{$_}=\%obj;
			push @{$$cref{OBJS}}, \%obj;
			push @{$$oref{CHILDO}}, $_;
			$obj{NAME}=$_, $obj{PAR}=$oref, $obj{FULLNAME}=$$oref{FULLNAME} ? $$oref{FULLNAME}.'::'.$_ : $_;
			$oref=\%obj;
		}
	}
	$$oref{USED}=1;

	return ($cref, $oref);
}

# finds an object given a name. assumes a local name if the name contains no ::
sub find_object($$)
{
	my ($obj, $par) = @_;
	if($opts{VERBOSE}>1) { print "find_object($obj,$par)\n"; }
	if($obj =~ /::/) {
		if(substr($obj, 0, 2) eq "::") { $obj = substr($obj, 2); }
		return get_object($obj);
	}

	while($par && !$$par{CHILDS}{$obj}) { $par=$$par{PAR}; }
	if(not $par) {
		warn "Unable to find object `$obj' - ${$_[1]}{AT}.\n";
		return undef;
	}
	return $$par{CHILDS}{$obj};
}

# gets an object, given a fully qualified name
sub get_object($)
{
	local $_;
	my $oref = \%objs;
	if($opts{VERBOSE}>1) { print "get_object($_[0])\n"; }
	for(split /::/, $_[0]) {
		if($$oref{CHILDS}{$_}) { $oref=$$oref{CHILDS}{$_}; }
		else
		{ warn "Unable to get object $_[0].\n";
		  return undef;
		}
	}
	return $oref;
}

# given an object reference, returns the HTML file in which this object resides
sub in_file($)
{
	if(not $domult) { return ""; }
	my $oref = shift;
	my $cref = $$oref{CAT};
	while(${$$cref{PAR}}{PAR}) { $cref=$$cref{PAR}; }
	return $$cref{NAME};
}

# scan a single file
sub scan_file($)
{
	local $/=undef;
	local $_;
	my ($fn, $FH, $ln, $cat, $obj, $dec, $type, $cref, $oref) = @_;
	my @lst;
	if($opts{VERBOSE}>1) { print "scan_file($fn)\n"; }
	if(open($FH, $fn)) {
		if($opts{VERBOSE}) { print "Scanning file '$fn'...\n"; }
		$curfile=$fn, $curline=0;
		$_=<$FH>;
		for(/~\(\s*(.+?)\s*\)~/sg) {
			if(/^([[:punct:]]+)\s/) { s/^$1\s+//gm; }
			if(/^!CATEGORIES/s) {
				s/.*\n//;
				parse_cats($_);
			}
			else {
				($cat, $type, $obj, $dec) = /^\s*([\w:]+)\s*,\s*(\w)\s*\'\s*([\w:]+)/s;
				if(not $obj) { utter "Error in object header: $cat, $type'$obj\n"; next; }
				s/^.*?\n(\s*?\n)*//sg;
				if(s'^~(?!\*)\s*(.*)$\n''m || s/~\*\s*?\n(.*?)\s*\*~\n*//s) { $dec=$1; }
				($cref, $oref) = add_object($cat, $obj);
				if($$oref{DEC} || $$oref{BODY}) {
					utter "Object `$$oref{FULLNAME}' being overwritten.";
				}
				$$oref{CAT}=$cref, $$oref{AT}=$curfile, $$oref{TYPE}=$type, $$oref{DEC}=$dec, $$oref{BODY}=$_;
			}
		}

		seek($FH, 0, 0);
		$/="\n";
		while(<$FH>) {
			$curline++;
			if(($obj)=/~\(\s*[\w:]+\s*,\s*\w\s*\'\s*([\w:]+)/) {
				$oref=get_object($obj);
				$$oref{AT}.="($curline)";
			}
		}
	}
	else { warn "Unable to open file: $fn\n"; }
}

# scan into directories recursively, calling scan_file for each matching file
sub scan_files($;$)
{
	local $_;
	my ($mask, $dir, $f, @files) = @_;

	if($opts{VERBOSE}>1) { print "scan_files($mask, $dir)\n"; }
	if($dir) {
		if($opts{VERBOSE}) { print "Entering directory '$dir'..."; }
		if(not chdir($dir)) { print " failed!\n"; return; }
		if($opts{VERBOSE}) { print "\n"; }
	}
	@files = grep { !-d } glob($mask);
	for $f(@files) { scan_file($f); }
	if($opts{RECURSE}) {
		my @dirs = grep { -d } glob('*');
		my $d;
		for $d(@dirs) {
			if($d !~ /^\./) { scan_files($mask, $d); }
		}
	}
	if($dir) {
		if($opts{VERBOSE}) { print "Leaving directory '$dir'.\n"; }
		chdir("..");
	}
}

# add beginning of HTML file
sub start_html($$)
{
	my ($F, $title) = @_;
	print $F <<EOF;
<html><head><title>$title</title>
<style>
body { font-family:Arial,Helvetica,Verdana; }
* { font-size:$opts{FONTSIZE}pt; }
.enum td { font-size:smaller; }
.objHead { font-weight:bold; display:block; }
.objDec,pre {
	background-color:#d0d0d0; border:1px solid black; margin:0.8em; padding:0.8em; display:block;
	font-family:courier new,courier; white-space:pre; font-size:smaller;
}
.objLoc { font-weight:normal; font-size:smaller; }
</style>
</head><body>
EOF
}

# add end of HTML file
sub end_html($)
{
	my $F = shift;
	print $F "</body></html>";
}

# substitude format tags in a string
sub html_replace($$)
{
	my ($str, $oref, $r) = @_;
	$str =~ s/`([\w:]+?)'/($r=find_object($1, $oref)) ? "<a href=\"".in_file($r)."#$$r{FULLNAME}\">$$r{FULLNAME}<\/a>" : "`$1'"/eg;
	$str =~ s/\^(\w+?)\^/<i>$1<\/i>/g;
	$str =~ s/!(\w+?)!/<b>$1<\/b>/g;
	return $str;
}

# replace html-like constructs with something that won't be parsed by a browser
sub tag_replace($)
{
	$_[0] =~ s/&/&amp;/sg;
	$_[0] =~ s/</&lt;/sg;
	$_[0] =~ s/>/&gt;/sg;
	return $_[0];
}

# replace specialized declarations
sub handle_dec($)
{
	local $_;
	my ($oref, $ret) = @_;
	SWITCH: {
		$$oref{TYPE} eq 'e' && do {
			$ret = '<table class="enum">';
			for(split /\n/, $$oref{DEC}) {
				s/^\s+|\s+$//g;
				my ($name, $desc) = split(/=/);
				$ret .= "<tr><td><b>$name</b></td><td>$desc</td></tr>";
			}
			$ret .= "</table>";
			last SWITCH;
		};
		# default
		$ret=$$oref{DEC};
	}
	return tag_replace($ret);
}

# write the index, recursively
sub write_cat_index($$;$)
{
	local $_;
	my ($F, $cat, $par, $cref, $aref) = @_;

	if($opts{VERBOSE}>1) { print "write_cat_index($cat, $par)\n"; }
	
	if(not $par) { $par=\%cats; }
	$cref = $$par{CHILDS}{$cat};
	print $F '<li class="indexCat">',$$cref{TITLE};

	$aref=$$cref{OBJS};
	if($aref && scalar(@{$aref}) || scalar(@{$$cref{CHILDO}})) {
		print $F "<br/><ul>";
		if($aref) {
			for(@{$aref}) {
				if($$_{USED}) { print $F "<li class=\"indexObj\"><a href=\"$curfile#$$_{FULLNAME}\">$$_{FULLNAME} ($$_{TYPE})</a></li>"; }
			}
		}
		if($aref=$$cref{CHILDO}) {
			for(sort @{$aref}) { write_cat_index($F, $_, $cref); }
		}
		print $F "</ul>";
	}
	print $F "</li>";
}

# write the objects in a category
sub write_catobjs($$;$)
{
	local $_;
	my ($F, $cat, $par, $cref, $str, $tmp) = @_;
	
	if($opts{VERBOSE}>1) { print "write_catobjs($cat, $par)\n"; }

	if(not $par) { $par=\%cats; }
	$cref = $$par{CHILDS}{$cat};
	for(@{$$cref{OBJS}}) {
		if($$_{USED}) {
			print $F "<a name=\"$$_{FULLNAME}\"/><span class=\"objHead\">$$_{FULLNAME} (<span class=\"objLoc\">type $$_{TYPE} - $$_{AT}</span>)</span>";
			if($$_{DEC})  { print $F "<pre>", html_replace(handle_dec($_), $_), "</pre>"; }
			if($$_{BODY}) {
				$str = html_replace($$_{BODY}, $_);
				$str =~ s/\<PRE\>(.*?)\<\/PRE\>/"<pre>".tag_replace($tmp=$1)."<\/pre>"/esg;
				print $F "<p class=\"objBody\">$str</p>";
			}
			print $F "<br/>";
		}
	}

	for(sort @{$$cref{CHILDO}}) { write_catobjs($F, $_, $cref); }
}

# generate one large output file
sub gen_single()
{
	local $_;
	my $FH;

	if($opts{VERBOSE}>1) { print "gen_single()\n"; }
	$domult=0;
	if(open($FH, $outdir."documentation.html")) {
		$curfile="";
		start_html($FH, $opts{PROJNAME}." Documentation");
		for(@{$cats{CHILDO}}) {
			print $FH "<h2>$opts{PROJNAME} Documentation</h2><h3>Table of Contents</h3><ul>";
			write_cat_index($FH, $_);
			print $FH "</ul><hr/><br/>";
		}
		for(@{$cats{CHILDO}}) { write_catobjs($FH, $_); }
		end_html($FH);
	}
	else { warn "Can't open output file '${outdir}documentation.html'\n"; }
}

# generate several output files, one per category, plus an index
sub gen_multi()
{
	local $_;
	my $FH;

	if($opts{VERBOSE}>1) { print "gen_multi()\n"; }
	$domult=1;
	if(open($FH, $outdir."index.html")) {
		start_html($FH, $opts{PROJNAME}." Documentation");
		for(@{$cats{CHILDO}}) {
			$curfile=$_.".html";
			print $FH "<h2>$opts{PROJNAME} Documentation</h2><h3>Table of Contents</h3><ul>";
			write_cat_index($FH, $_);
			print $FH "</ul>";
		}
		end_html($FH);
	}
	else { warn "Can't open output file '${outdir}index.html'\n"; }
	$curfile="";

	for(@{$cats{CHILDO}}) {
		if(open($FH, "$outdir$_.html")) {
			start_html($FH, $opts{PROJNAME}." Documentation - ${$cats{CHILDS}{$_}}{TITLE}");
			print $FH "<a href=\"index.html\">Back to Index</a><h2>$opts{PROJNAME} Documentation - ${$cats{CHILDS}{$_}}{TITLE}</h2><h3>Table of Contents</h3><ul>";
			write_cat_index($FH, $_);
			print $FH "</ul><hr/><br/>";
			write_catobjs($FH, $_);
			end_html($FH);
		}
		else { warn "Can't open output file '$outdir$_.html'\n"; }
	}
}

sub usage()
{
	print <<EOF;
autodoc [options] filemasks...

autodoc v. 0.91 beta
The autodoc program documents source code by scanning for specially formatted
text within the files matching the filemasks passed in.

OPTIONS:
-h	Display this message and exit
-m	Generate multiple HTML files, one per topic
-o path	Write the files in the specified path (default is .)
-p name	Set the project name to 'name'. Defaults to "Project"
-r	Recurse into subdirectories when looking for files to scan
-s	Generate a single HTML file with the documentation (default)
-v	Increase verboseness level. Using more than once generates debug info
EOF
	exit(-1);
}

sub main()
{
	my ($c, $i, $s);
	
	if(scalar(@ARGV)==0) { usage(); }

	$opts{GENSINGLE}=1;
	$opts{PROJNAME}="Project";
	$opts{FONTSIZE}=10;
	
	for($i=0; $i<scalar(@ARGV); $i++) {
		if(($_=$ARGV[$i]) =~ /^-/) {
			if(!$s && /m/) { $opts{GENSINGLE}=0; }
			$_=reverse $_;
			while($c=lc chop) {
			  SWITCH: {
					$c eq 'f' && do { $opts{FONTSIZE}=$ARGV[++$i]; last SWITCH; };
					$c eq 'm' && do { $opts{GENMULTI}=1;   last SWITCH; };
					$c eq 'o' && do { $outdir=$ARGV[++$i]; last SWITCH; };
					$c eq 'p' && do { $opts{PROJNAME}=$ARGV[++$i]; last SWITCH; };
					$c eq 'r' && do { $opts{RECURSE}=1;    last SWITCH; };
					$c eq 's' && do { $opts{GENSINGLE}=$s=1;last SWITCH; };
					$c eq 'v' && do { $opts{VERBOSE}++; last SWITCH; };
					$c eq 'h' && do { usage(); };
				}
			}
		}
		else { last }
	}
	if(not $outdir) { $outdir=">./"; }
	else {
		if(substr($outdir, -1) ne '/') { $outdir .= '/'; }
		$outdir = ">".$outdir;
	}
	
	for $i(@ARGV[$i..$#ARGV]) { scan_files($i); }
	if($opts{GENSINGLE}) { gen_single(); }
	if($opts{GENMULTI})  { gen_multi();  }
}

# call main to start
main;
