#!/usr/local/bin/perl5 -w
#
#	webc
#
#	A web "compiler".
#
#	This is a simple translator which converts a source file
#	into a *.html file suitable for being served by the web
#	server.
#
#	This is a mix of perl, html, and C.  It is also an ad'hoc
#	system.
#
#	Dave Regan
#	regan@ao.com
#	http://www.ao.com/~regan/Webc
#	31 January 1997
#
#	This program and the associated documentation are in the
#	public domain.
#

###
###	Configuration
###

#use strict 'vars';
use strict 'refs';
use strict 'subs';
#use diagnostics;

$Symbols{'__VERSION__'} = "v0.20";	# Current version ID

@MonName = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
	     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');


###
###	Main program
###

    # Stash a guess for the site name.
    # It is reasonable for the user to override this.
    $DoExpand = 1;
    $ENV{'LOGNAME'} = "unknown" if (!defined($ENV{'LOGNAME'}));
    $Symbols{'__SITE__'} = `hostname` . "." . `domainname`;
    $Symbols{'__SITE__'} =~ s/\n//;
    $Symbols{'__USER__'} = $ENV{'LOGNAME'};
    $Symbols{'__EMAIL__'} = "$Symbols{'__USER__'}\@$Symbols{'__SITE__'}";
    $CallFuncs{'DumpVars'} = 1;

    if (!$InCGI)
    	{
	for $file (@ARGV)
	    {
	    if ($file =~ /\.html$/)
		{
		print "Not processing $file.  It already is an HTML file.\n";
		next;
		}
	    Compile($file);
	    }
	exit 0;
	}

    return 1;


######
######	Compilation routines
######
######	Template files exist which describe the work to be done.
######	Each of these gets turned into an html file with appropriate
######	substitutions made.
######
######	Substitutions include the following macros:
######		__DATE__	The current date
######		__TIME__	The current time
######		__MODIFIED__	The last modified date
######		__SITE__	The web site name
######		__FILE__	The current filename
######		__HTMLFILE__	The current output filename
######		__USER__	The current username
######		__EMAIL__	The email of the current user
######		__VERSION__	The current webc version ID
######	in addition to any the user defines.  Some of the standard
######	definitions are "guesses", and the user is free to override
######	any of these.
######
######	Preprocessor directives understood:
######		#include fname	A filename to include
######				Include files nest, but don't put it into a loop
######		#call fn	Call a specific function
######		#localcode fname Read a file into the compiler itself.
######		#define X val	Define a value
######		#pragma name	A Webc hack
######		#if val string	Print a string if the val is not 0
######		#callable fn	Indicates that the named function
######				can be called anyplace it sees "fn()".
######

###
###	CanonFname
###
###	Remove redundancies from a filename.
###
sub CanonFname
    {
    local($fname) = @_;

    $fname =~ s#/+#/#g;
    $fname =~ s#/\./#/#g while ($fname =~ m#/\./#);
    $fname =~ s#^\./##g;
    $fname =~ s#[^/]+/\.\./## while ($fname =~ m#/\.\./#);
    return $fname;
    }


###
###	Compile
###
###	Compile a single file.
###
sub Compile
    {
    local($fname) = @_;
    local(@tm);

#   print "Compiling $fname\n";

    # Open the file for reading, and also a file for writing.
    # The output filename is *.html.
    $fname = CanonFname($fname);
    ($Symbols{'__HTMLFILE__'} = $fname) =~ s/\.[a-zA-Z]*$/.html/;

    # Define appropriate symbols
    $Symbols{'__FILE__'} = $fname;
    @tm = localtime();
    $Symbols{'__DATE__'} =
    		sprintf "%d %s %d", $tm[3], $MonName[$tm[4]], $tm[5] + 1900;
    $Symbols{'__TIME__'} = sprintf "%02d:%02d:%02d", $tm[2], $tm[1], $tm[0];
    @tm = localtime((stat($fname))[9]);
    $Symbols{'__MODIFIED__'} =
    		sprintf "%d %s %d", $tm[3], $MonName[$tm[4]], $tm[5] + 1900;

    if ($InCGI)
    	{
    	$Symbols{'__HTMLFILE__'} = "<STDOUT>";
    	*OUT = *STDOUT;
    	}
    else
    	{
	if (!open(OUT, ">$Symbols{'__HTMLFILE__'}"))
	    {
	    print "Cannot open html file $Symbols{'__HTMLFILE__'}\n";
	    return;
	    }
	}

    CompileRead(".", $fname);

    close OUT if (!$InCGI);
    }


###
###	CompileRead
###
###	Read in a file.
###
sub CompileRead
    {
    local($parentdir, $fname) = @_;
    local(*IN, $dir, $line, $string, $sym, $val);

    # Make a directory which tracks what is being read.
    # The directory may have redundant dir/../ in it, but that's ok.
    $dir = $fname;
    $dir = "$parentdir/$fname" if ($fname !~ m#^/#);
    $dir =~ s#/[^/]*$##;
#print STDERR "Opening $fname, dir is $dir\n";
    $fname =~ s#.*/##;

    if (!open(IN, "<$dir/$fname"))
	{
	print "Cannot open source file $dir/$fname\n";
	return;
	}
#    print "Reading $dir/$fname\n";

    while (<IN>)
	{
#print STDERR "Process $_";
	if (/^\s*#/)
	    {
#	    print STDERR "Process $_";
#print STDERR ".";
	    chomp;
	    $line = $_;

	    # See if we should include a file
	    CompileRead($dir, Expand($1))
	    		if ($line =~ /^\s*#\s*include ["<]*([^">]+).*/);

	    # See if we should source a file
	    require("$dir/" . Expand($1))
	    		if (!$NoLocalcode &&
	    		    $line =~ /^\s*#\s*localcode ["<]*([^">]+).*/);

	    # See if there is a procedure to call
	    if ($line =~ /^\s*#\s*call/)
	    	{
	    	$line = Expand($line);
	    	$Directory = $dir;

		# If running as the real user, let them call any
		# function in any way that they want.  If it is part
		# of a CGI program on a restricted machine, then
		# only call functions which are in the CallFuncs hash.
		# eval("$1('$2')") if ($line =~ /^\s*#\s*call\s+["<]?([^"\s>]+).?\s*(.*)/);
		if ($line =~ /^\s*#\s*call\s+["<]?([^"\s>]+).?\s*(.*)/)
		    {
		    my($func, $param) = ($1, $2);
		    if ($NoLocalcode)
			{
			if ($CallFuncs{$func} eq "")
			    {
			    print OUT "Function $func is not registered in CallFuncs\n";
			    }
			else
			    {
			    eval("$func('$param')");
			    }
			}
		    else
		    	{
			eval("$func('$param')");
		    	}
		    }
		}

	    # See if this is a variable definition
	    $Symbols{$1} = Expand($2) if ($line =~ /^\s*#\s*define\s+(\S+)\s+(.*)/);

	    # See if this is a pragma (hack)
	    Pragma($1) if ($line =~ /^\s*#\s*pragma\s+(\S+)/);

	    # See if this is a simple #if
	    if ($line =~ /^\s*#\s*if\s+(\S+)\s+(.*)/)
	    	{
	    	$val = Expand($1);
	    	$string = Expand($2);
	    	if ($val ne "" && $val ne "0")
	    	    {
	    	    print $string;
	    	    }
	    	}

	    # See if this defines a callable function
	    $Callable{$1} = 1 if ($line =~ /^\s*#\s*callable\s+(.*)/);
	    }
	else
	    {
	    $_ = Expand($_);

	    print OUT "$_";
	    }
	}
    close IN;
    }


###
###	Expand
###
###	Expand the macros in a string.
###
###	This can cause loops in a number of ways.  We will take
###	the lazy way out and keep a counter for the number of
###	expansions and give up after awhile.
###
###	The order of expansion is not guarenteed.
###
sub Expand
    {
    local($_) = @_;
    local($count1, $count2, $fn, $sym);

    return $_ if (!$DoExpand);
    for ($count1 = 0; $count1 < 100; $count1++)
    	{
    	# Call any functions found
    	$count2 = 0;
	for $fn (keys %Callable)
	    {
	    next if ($fn eq "");
	    while (/(.*)$fn\s*\((.*?)\)(.*)/)
	    	{
	    	$count2++;
	    	$_ = $1 . eval("$fn('$2')") . "$3\n";
	    	}
	    }

    	# Expand any macros found
	for $sym (keys %Symbols)
	    {
	    next if (!defined($sym) || $sym eq "" || !defined($Symbols{$sym}));
	    $count2 += s/$sym/$Symbols{$sym}/g;
	    }
	last if ($count2 == 0);
	}
    return $_;
    }


###
###	Pragma
###
###	A place to collect hacks.  The less said about these the better.
###
sub Pragma
    {
    local($pragma) = @_;

    $DoExpand = 0 if ($pragma eq "nodefine");
    $DoExpand = 1 if ($pragma eq   "define");
    }


###
###	RootRelative
###
###	We have a filename which is supposed to be relative from
###	the root of the document tree.  However, the filename will
###	be used relative to the current file being compiled (e.g.
###	the web browser).  So modify the name to be relative to
###	the current filename.
###
sub RootRelative
    {
    local($reference, $fname) = @_;
    local($count, $tmp);

    return $fname if ($fname =~ m#^/#);

    ($tmp = CanonFname($reference)) =~ s#[^/]##g;
    for ($count = 0; $count < length($tmp); $count++)
    	{
    	$fname = "../$fname";
    	}
    return $fname;
    }


######
######	Routines for the user to call.
######

###
###	Test
###
###	See if this gets a parameter
###
sub Test
    {
    local($param) = @_;

    print "Param is \"$param\"\n";
    }


###
###	Modified
###
###	Print an appropriate modification notice.
###
sub Modified
    {
    print OUT "<br><i>Last modified $Symbols{'__MODIFIED__'}</i><br>\n";
    }


###
###	HotBar
###
###	Produce a "hot button bar" in the current location.
###
###	Call with:
###		#call HotBar PAGELIST.FILE HOTBAR.FILE
###	To represent a missing entry, pass in /dev/null.
###
###	The PAGELIST.FILE is used to specify the order that pages
###	are to be ordered in the document.
###
###	The HOTBAR.FILE indicates which buttons to put on the
###	hotbar.
###
###	It might be nice to have images associated with buttons.
###
sub HotBar
    {
    local($args) = @_;
    local($prev, $next);
    local($basename, $fname, $hotbar, $item, $last, $name, @names);
    local($pagelist, $value, @values);

    # First find the previous and next information
    $prev = "";
    $next = "";
    ($pagelist, $hotbar) = split(/\s+/, $args);
    if ($pagelist eq "" || $hotbar eq "")
    	{
    	print "Usage: #call HotBar PAGELIST.FILE HOTBAR.FILE\n";
    	return;
    	}
#print "Before $pagelist $hotbar\n";
    $pagelist = "$Directory/$pagelist" if ($pagelist !~ m#^/#);
    $hotbar   = "$Directory/$hotbar"   if ($hotbar   !~ m#^/#);
    $pagelist = CanonFname($pagelist);
    $hotbar   = CanonFname($hotbar);
#print "After $pagelist $hotbar\n";

    if (!open(PL, "<$pagelist"))
	{
	print "Cannot open pagelist $pagelist\n";
	}
    else
	{
	# Find previous item
	$last = "";
	while (<PL>)
	    {
	    chomp;
	    $last = $_;
	    next if (/^#/);
	    last if (/^$Symbols{'__HTMLFILE__'}$/);
	    $prev = $_;
	    }
	$prev = "" if ($last !~ /^$Symbols{'__HTMLFILE__'}$/);

	# Find the next item
	while (<PL>)
	    {
	    chomp;
	    next if (/^#/);
	    $next = $_;
	    last;
	    }
	close PL;
#print "Make $prev relative from $Symbols{'__HTMLFILE__'}  ";
	$prev = RootRelative($Symbols{'__HTMLFILE__'}, $prev) if ($prev ne "");
#print "giving $prev.\n";
#print "Make $next relative from $Symbols{'__HTMLFILE__'}  ";
	$next = RootRelative($Symbols{'__HTMLFILE__'}, $next) if ($next ne "");
#print "giving $next\n";
	}

    # Find the pairs of URLs/description.
    if (!open(HB, "<$hotbar"))
	{
	print "Cannot open hotbar file $hotbar\n";
	}
    else
	{
	while (<HB>)
	    {
	    chomp;
	    next if (/^#/);
	    $_ = Expand($_);		# Expand the results
	    ($name = $_) =~ s/\s.*$//;
	    ($value = $_) =~ s/^\S+\s+//;
	    push(@names, $name);
	    push(@values, $value);
	    }
	close HB;
	}

    # OK.  We've now got all the information we are going to get.
    # It's time to emit the code.
    print OUT "<hr>\n";
    print OUT "[<a href=\"$prev\">Previous</a>]\n" if ($prev ne "");
    for ($item = 0; $item <= $#names; $item++)
    	{
    	$basename = $names[$item];
    	$basename =~ s/\.[^.]*$//;
    	if (($Symbols{'__FILE__'} =~ m#/$basename#) ||
    	    ($Symbols{'__FILE__'} =~ m#^$basename#))
    	    {
    	    print OUT "[$values[$item]]\n";
    	    }
	else
	    {
	    $basename = $names[$item];
	    $basename .= ".html" if ($basename !~ /\./);
	    print OUT "[<a href=\"$basename\">$values[$item]]</a>\n";
	    }
    	}
    print OUT "[<a href=\"$next\">Next</a>]\n" if ($next ne "");
    print OUT "<hr>\n";
    }


###
###	DumpVars
###
###	Dump the current symbol table.
###
sub DumpVars
    {
    local($key);

    print OUT "<p>\n";
    for $key (sort(keys %Symbols))
    	{
    	print OUT "#define $key\t$Symbols{$key}<br>\n";
    	}
    }


###
### AnchorTable Call
###
### This little function creates a table in an html file using the 
### webc compiling software.  Its lone argument in the file which
### contains the anchors for that particular file.  I suggest the
### format {filename}.anchor.h so things don't get confusing.
###
###	This code added by renee.
###

sub AnchorTable  {
    local($args)=@_;
    chomp($args);
    local(@Anchor, @Anchorlist)=();    
    local($r,$Length);
# The Program attempts to open the anchor list called, and woe to ye
# who improperly calls this file.

    if (!open(AT,"<$args"))  {
         print "File \"$args\" does not exist.\n";
	 return;
        }
    print "Processing $args\n";

# The program now defines a handy 2-D array %Anchorlist which contains
# the split quantities Table data and key(anchor name).


    while(<AT>)  {
        $TheLine=$_;
        chomp($TheLine);
	$TheLine =~ s/^\s*//;
	$TheLine =~ s/\s*$//;
        if ($TheLine =~ /^\#/ || $TheLine !~ /\s/)  {next};
#        @Anchor =  split(/\s+/, $TheLine);
#        while(1)  {
#        if ($Anchor[2] =~ /\S+/)  {
#           $Anchor[1] = "$Anchor[1] $Anchor[2]";
#           splice(@Anchor, 2, 1);
#           }
#        else {last}
#        }
	($Anchor[0] = $TheLine) =~ s/\s.*//;
	($Anchor[1] = $TheLine) =~ s/^[^\s]*\s+//;
        push(@Anchorlist,[ "$Anchor[0]" , "$Anchor[1]" ])
        }

# now we figure out what kind of table we wish to create, for anchor
# lists containing (gasp! the evil fiends!) 9 or more entries, we 
# create a three wide table, for smaller tables a two column table
# will do.

$TableChoice=@Anchorlist;
$r = $TableChoice;
if ($TableChoice < 9) {
    print OUT "<CENTER><TABLE>\n";
    for($i=0; $i < ($TableChoice); $i=$i+2)  {
    print OUT "<TR valign=top>\n<TD>\n";
    print OUT "<A HREF=\"#$Anchorlist[$i][0]\">$Anchorlist[$i][1]</A>\n</TD>";
    $r -= 1;
           unless($r == 0)  {
        print OUT "<TD>\n";
        print OUT "<A HREF=\"#$Anchorlist[($i+1)][0]\">" .
                  "$Anchorlist[($i+1)][1]</A>\n</TD></TR>";       
        $r -= 1   
           }
        }
     print OUT "</TABLE></CENTER>\n"     
     }
# Now we do the bigger table
if ($TableChoice >=9)  {
    print OUT "<CENTER><TABLE>\n";
    for($i=0; $i < ($TableChoice); $i=$i+3)  {
       print OUT "<TR valign=top>\n<TD>\n";
       print OUT "<A HREF=\"#$Anchorlist[$i][0]\">$Anchorlist[$i][1]</A>\n";
       print OUT "</TD>\n";
       $r -= 1;
       unless ($r == 0)  {
           print OUT "<TD><A HREF=\"#$Anchorlist[($i+1)][0]\">" .
                     "$Anchorlist[($i+1)][1]</A>\n</TD>\n";
           $r -= 1;
           }
       unless ($r == 0)  {
           print OUT "<TD><A HREF=\"#$Anchorlist[($i+2)][0]\">" .
                     "$Anchorlist[($i+2)][1]</A>\n</TD>\n";
           $r -= 1;
           }
       }   
    print OUT "</TABLE></CENTER>\n"
    }        
 
# Now we have the Anchortables added properly to the appropriate files
# Ergo, end of subroutine

}


### Anchor Call 
### This function is called by the method:
### #call Anchor {name of anchor in the anchor file assoc w/ file}
sub Anchor  {
    local($arg)=@_;
    chomp;
    print OUT "<A NAME=\"$arg\">";
# And that is all there is to it
}


###  Call Segment function 
###  This function creates a line with a logo image, title, and
###  several navigational buttons.
###  To call this function do #call Segment {filename}, where 
###  filename is the file containing the appropriate navigational
###  buttons (their names and their targets).  The format for the
###  file is target file name and then the name of the button 

sub Segment  {
local($File)=@_;
local($TheLine,@NavBut,@NavList,$Length);
chomp($File);

unless (open(READ, "$File")) {
    print "Your navigation button file does not exist.\n";
    }
while(<READ>)  {
        $TheLine=$_;
        chomp($TheLine);
        if ($TheLine =~ /^\#/)  {next};
        @NavBut =  split(/\s+/, $TheLine);
        while(1)  {
        if ($NavBut[2] =~ /\S+/)  {
           $NavBut[1] = "$NavBut[1] $NavBut[2]";
           splice(@NavBut, 2, 1);
           }
        else {last}
        }
        push(@NavList,[ "$NavBut[0]" , "$NavBut[1]" ])
        }
close(READ);
$Length=@NavList;

# As the file being used comes in table form already, we must take
# ourselves out of table form as at least my version of netscape
# does not like tables in table

print OUT "<CENTER><TABLE>\n";
print OUT "<TR><TD COLSPAN=3 ROWSPAN=$Length>\n";
print OUT "<IMG SRC=\"_LOGO_\" ALIGN=\"middle\"></TD>\n";
print OUT "<TD COLSPAN=3 ROWSPAN=$Length>";
print OUT "<H1>_SUBTITLE_</H1></TD>\n";

for ($i=0; $i < $Length; $i++)  {
    unless ($i == 0)  {print OUT "<TR>"};
    print OUT "<TD>\n";
    print OUT "<A HREF=\"$NavList[$i][0]\">$NavList[$i][1]</A>\n";
    print OUT "</TD></TR>\n";
    }

# We're now down with the meat of the table, so we finish it off and
# go back

print OUT "</TABLE></CENTER>\n";

}