#!/usr/bin/perl -w

use URI;
use URI::file;
#use Carp;
use strict;
use integer;

# Config file variables
use vars qw(%Roots $IndexFile $ImageIsComposite $FileSuffix
    $ImagePrefix $ImageSuffix $ImageSpace $ImageAltSpace $ImageDown
    $ImageAltDown $ImageRight $ImageAltRight $ImageLine $ImageAltLine
    $ImageEnd $ImageAltEnd $ImageBar $ImageAltBar $ImageWebRoot
    $HTMLPrefixMarker $HTMLSuffixMarker $HTMLNavBarMarker $HTMLPrefix
    $HTMLNavBarPrefix $HTMLNavBarSuffix $HTMLPreLinkPrefix
    $HTMLPostLinkPrefix $HTMLPreLinkSuffix $HTMLPostLinkSuffix
    $HTMLActPreLinkPrefix $HTMLActPostLinkPrefix $HTMLActPreLinkSuffix
    $HTMLNoLinkPrefix $HTMLNoLinkSuffix
    $HTMLActPostLinkSuffix $HTMLSuffix $HTMLHREF $HTMLIMG $UseRelURLs
    $HTMLHREFInAct $HTMLHREFAct
    @Menu);

# These still need to be global as of now...
my $is;
my %treeStrings = ();

planter();

#------------------------------------------------------------------------------

sub planter {

    # Input the config file
    if ($#ARGV < 0) {
	# No argument, try ./.planter
	require ".planter";
    } elsif (-d $ARGV[0]) {
	require $ARGV[0] . "/.planter";
    } else {
	require $ARGV[0];
    }

    # Initialize
    my %paths = ();

    # undef would be better as a base, but URI doesn't like that
    my $tree = hashTreeFromMenu("http://www.example.com/", 0, \@Menu);

    my $tree2 = recursiveCopyItem($tree);

    my @parents = ();
    walk(\&collectLocalFileList, \%paths, \@parents, [ $tree2 ]);

    foreach my $key (keys(%paths)) {
	# Calculate menu tree for all URLs
	my $tree3 = recursiveCopyItem($tree2);
	# Two passes: First decide which ones are necessary, then delete/keep
	walkDepthFirst(\&prunePass1,  $key, [ $tree3 ], undef);
	walkDepthFirst(\&prunePass1a, $key, [ $tree3 ], undef);
	walkDepthFirst(\&prunePass2,  $key, [ $tree3 ], undef);
	# These globals are being used during build; globals are simpler (though uglier)
	@parents = ();
	$is = "";
	walk(\&build, $key, \@parents, [ $tree3 ]);
	if (defined(ref($paths{$key})) && ref($paths{$key}) ne "") {
	    patchFiles($key, $is, @{$paths{$key}});
	} else {
	    patchFile($key, $is);
	}
    }

    my @createImages = ();
    foreach my $key (keys(%treeStrings)) {
	if (checkImage($key)) {
	    push(@createImages, $key);
	}
    }

    my $tmp;
    my @tmpfiles;
    if ($#createImages >= 0) {
	if ($ImageSuffix ne ".png") {
	    die "Don't know how to create " . $ImageSuffix . " files\n";
	}
	$tmp = "/tmp/planter" . $$;
	@tmpfiles = ();
	mkdir $tmp, 0700 || die "Can't create temporary directory: " . $!;
	foreach my $key (@createImages) {
	    createImage($key, $tmp . "/", \@tmpfiles);
	}
	unlink @tmpfiles;
	rmdir $tmp || print STDERR "Could not remove", $tmp, "; " , $!;
    }
}

#==============================================================================

sub createImage {
    my $composite = shift;
    my $tmp = shift;
    my $tmpfiles = shift;

    my $prefix = fileForURL($ImageWebRoot) . $ImagePrefix;

    # Combine the file list, make sure files are here
    # Need redirect for pnmcat, so we make a single string
    my $files = "";
    my $afiles = "";
    for (my $i = 0; $i < length($composite); $i++) {
	my $char = substr($composite, $i, 1);
	unless (-f "$tmp$char.pnm") {
	    # Create that file, not here yet
	    system("pngtopnm $prefix$char$ImageSuffix > "
		   . "$tmp$char.pnm\n"); # or die "pngtopnm $char.pnm: $!";
	    system("pngtopnm -alpha $prefix$char$ImageSuffix > "
		   . "$tmp$char.pnma\n"); # or die "pngtopnm $char.pnma: $!";
	    push(@$tmpfiles, "$tmp$char.pnm");
	    push(@$tmpfiles, "$tmp$char.pnma");
	}
	$files .= "$tmp$char.pnm ";
	$afiles .= "$tmp$char.pnma ";
    }

    # Concatenate images
    system("pnmcat -lr $files > $tmp$composite.pnm\n"); # or die "pnmcat";
    system("pnmcat -lr $afiles > $tmp$composite.pnma\n"); # or die "pnmcat alpha";

    # Back to png
    system("pnmtopng -alpha $tmp$composite.pnma $tmp$composite.pnm "
	   . " > $prefix$composite$ImageSuffix\n"); # or die "pnmtopng";

    unlink("$tmp$composite.pnm") or print STDERR "Cannot unlink $tmp$composite.pnm";
    unlink("$tmp$composite.pnma") or print STDERR "Cannot unlink $tmp$composite.pnma";
    
    print STDERR "Created image for " . $composite . "\n";
}

#------------------------------------------------------------------------------

sub checkImage {
    my $composite = shift;

    my $prefix = fileForURL($ImageWebRoot) . $ImagePrefix;

    if (-f $prefix . $composite . $ImageSuffix) {
	# Everything fine, do nothing
	return 0;
    } else {
	# Need to create the image later
	return 1;
    }
}

#------------------------------------------------------------------------------

sub patchFile {
    my $key = shift;
    my $is = shift;
    my $file = URI::file->new(fileForURL($key));

    if (-d $file->path) {
	$file = URI->new_abs($IndexFile, $file);
    }
    if (! -f $file->path) {
	$file = URI::file->new($file->path . $FileSuffix);
    }
    patchSomeFile($file, $is);
}

#------------------------------------------------------------------------------

sub patchFiles {
    my $key = shift;
    my $is = shift;

    while (my $thisFile = shift) {
	my $file = URI->new_abs($thisFile, fileForURL($key));
	patchSomeFile($file, $is);
    }
}

#------------------------------------------------------------------------------

sub patchSomeFile {
    my $file = shift;
    my $is = shift;

    $/ = undef; # Read the entire file
    my $path = $file->path;

    open(HTML, "<$path") or die("open(read, $path): " . $!);
    my $idxfile = <HTML>;
    die("read: " . $path . ": " . $!) unless defined($idxfile);
    close(HTML);

    my $currentState = $idxfile;
    
    $idxfile = replace($idxfile, $HTMLPrefixMarker, $HTMLPrefix, $path);
    $idxfile = replace($idxfile, $HTMLSuffixMarker, $HTMLSuffix, $path);
    $idxfile = replace($idxfile, $HTMLNavBarMarker,
		       $HTMLNavBarPrefix . $is . $HTMLNavBarSuffix, $path);

    if ($idxfile ne $currentState) {
	print STDERR "Updating ", $path, "\n";
	open(HTML, ">$path") or die("open(write, $path)" . $!);
	print HTML $idxfile or die("write to " . $path . ": " . $!);
	close(HTML);
    }
}

#------------------------------------------------------------------------------

sub replace {
    my $input = shift;
    my $pattern = shift;
    my $new = shift;
    my $path = shift;

    # I don't want to use s///, since we could have all kinds of chars
    my $startstr = "<!-- -----BEGIN " . $pattern . "----- -->";
    my $endstr = "<!-- -----END " . $pattern . "----- -->";

    my $start = index($input, $startstr);
    die("Find " . $startstr . " in " . $path) if ($start < 0);
    $start += length($startstr);

    my $end = index($input, $endstr);
    die("Find " . $endstr . " in " . $path) if ($end < $start);
    
    substr($input, $start, $end - $start) = $new;
    return $input;
}

#------------------------------------------------------------------------------

sub build {
    my $base = shift;
    my $hash = shift;
    my $parents = shift;
    my $chain = shift;
    my $i = shift;
    my $node = $chain->[0];

    if (defined($hash->{link}) && $hash->{basepath} eq $base) {
        $is .= imgString($base, $#$node, $i < $#$node, # more?
		        $parents, defined($hash->{children}) )
	    . $HTMLActPreLinkPrefix
	    . (defined($hash->{link})
	       ? '<A HREF="' . relativeURL($hash, $base) . '"' . $HTMLHREF . $HTMLHREFAct . '>'
	       : $HTMLNoLinkPrefix )
	    . $HTMLActPostLinkPrefix . $hash->{name} . $HTMLActPreLinkSuffix
	    . (defined($hash->{link}) ? '</A>' : $HTMLNoLinkSuffix)
	    .  $HTMLActPostLinkSuffix . "<BR>\n";
    } else {
        $is .= imgString($base, $#$node, $i < $#$node, # more?
		        $parents, defined($hash->{children}) )
	    . $HTMLPreLinkPrefix
	    . (defined($hash->{link})
	       ? '<A HREF="' . relativeURL($hash, $base) . '"' . $HTMLHREF . $HTMLHREFInAct . '>'
	       : $HTMLNoLinkPrefix )
	    . $HTMLPostLinkPrefix . $hash->{name} . $HTMLPreLinkSuffix
	    . (defined($hash->{link}) ? '</A>' : $HTMLNoLinkSuffix)
	    .  $HTMLPostLinkSuffix . "<BR>\n";
    }
    return 1; # Keep item
}

#------------------------------------------------------------------------------

sub relativeURL {
    my $me = shift;
    my $base = shift;
    my $relative = $UseRelURLs;

    # Use per-entry value
    if (defined($me->{relative})) {
	$relative = $me->{relative};
    }

    if ($relative eq "never") {
	return $me->{path};
    } else {
	my $relguess = $me->{path}->rel($base);

	if ($relative eq "always") {
	    return $relguess;
	} elsif ($relative eq "within") {
	    # Neither path-absolute (/...) nor with a scheme (...:...)
	    if (substr($relguess, 0, 1) ne '/' && index($relguess, ':') < 0) {
		return $relguess;
	    } else {
		return $me->{path};
	    }
	} elsif ($relative eq "nice") {
	    my $relsave = $relguess;
	    $relguess =~ s,^(\.\./)*,,g;  # Drop leading ../
	    if ("/" . $relguess eq $me->{path}->path) {
		# Directly start rooting at /
		return $me->{path}->path;
	    } else {
		return $relsave;
	    }
	} else {
	    die "Invalid value: relative/UseRelURLs = $relative\n";
	}
    }
}

#------------------------------------------------------------------------------

# Set "forceexpand" on 'current' (=$param) page; propagate "forceexpand" up
sub prunePass1 {
    my $param = shift;
    my $hash = shift;
    my $chain = shift;
    my $i = shift;
    my $parent = shift;

    if (((defined($hash->{basepath}) && $hash->{basepath} eq $param)
	 || defined($hash->{forceexpand}))) {
	$hash->{forceexpand} = 1;
	if (defined($parent)) {
	    $parent->{forceexpand} = 1; # Mark parent as important as well
	}
    }
    return 1; # Do not delete during pass1
}

#------------------------------------------------------------------------------

# Upgrade "autoexpand" to "forceexpand" on all nodes whose parent has "forceexpand"
sub prunePass1a {
    my $param = shift;
    my $hash = shift;
    my $chain = shift;
    my $i = shift;
    my $parent = shift;

    if (defined($parent) && defined($parent->{forceexpand}) &&
	defined($hash->{autoexpand})) {
	$hash->{forceexpand} = 1;
    }
    return 1; # Do not delete during pass1a
}

#------------------------------------------------------------------------------

sub prunePass2 {
    my $param = shift;
    my $hash = shift;
    my $chain = shift;
    my $i = shift;
    my $parent = shift;

    # Normalize (keep only non-empty children pointers)
    if (defined($hash->{children}) && $#{$hash->{children}} < 0) {
	delete $hash->{children};
    }

    if ((defined($parent) && defined($parent->{forceexpand})
	 && !defined($hash->{hidden}))
	|| defined($hash->{children})
	|| (defined($hash->{forceexpand}))) {
	return 1; # Do not delete item
    } else {
	return 0; # No use for us, delete
    }
}

#------------------------------------------------------------------------------

sub fileForURL {
    my $url = shift;
    my $matchLength = 0;
    my $longestMatch = undef;

    # Does a longest prefix match on the keys in %Roos
    foreach my $i (keys(%Roots)) {
	if (length($i) > $matchLength) {
	    if (substr($url, 0, length($i)) eq $i) {
		$matchLength = length($i);
		if (defined($Roots{$i})) {
		    $longestMatch = $Roots{$i} . substr($url, length($i));
		} else {
		    $longestMatch = undef;
		}
	    }
	}
    }
    return $longestMatch;
}

#------------------------------------------------------------------------------

sub collectLocalFileList {
    my $pathsParam = shift;
    my $hash = shift;
    my $parents = shift;
    my $chain = shift;
    my $i = shift;
    my $ffu;

    if (defined($hash->{basepath})) {
	$ffu = fileForURL($hash->{basepath});
    }
    # In our namespace? Or are we forbidden to touch it?
    if (!defined($hash->{nomenu}) && defined($ffu)) {
	# When there are multiple references to the same basepath,
	# the one with the "files" property takes precedence
	# (all others should be equal anyway); thus don't overwrite
	# an existing entry with the generated filename
	if (defined($hash->{files})) {
	    $pathsParam->{$hash->{basepath}} = $hash->{files};
	} elsif (!defined($pathsParam->{$hash->{basepath}})) {
	    $pathsParam->{$hash->{basepath}} = $ffu;
	}
    }
    return 1; # Do not delete item
}

sub walk {
    my $udf = shift;
    my $udfparam = shift;
    my $parents = shift;
    my $chain = shift;
    my $node = $chain->[0];

    my $i = 0;
    while ($i <= $#$node) {
	my $hash = $node->[$i];

	if (defined($hash->{children})) {
	    push(@{$parents}, 1);
	} else {
	    push(@{$parents}, 0);
	}

	if (&$udf($udfparam, $hash, $parents, $chain, $i) == 0) {
	    # delete this item
	    splice(@$node, $i, 1);
	    # No need to adjust @parents, will be popped
	} else {
	    if (defined($hash->{children})) {
		if ($i == $#$node) {
		    ${$parents}[$#{$parents}] = 0;
		}
		walk($udf, $udfparam, $parents, [ $hash->{children}, @$chain ]);
	    }
	    $i++;
	}
	pop(@{$parents});
    }
}

#------------------------------------------------------------------------------

sub walkDepthFirst {
    my $udf = shift;
    my $udfparam = shift;
    my $chain = shift;
    my $parent = shift;
    my $node = $chain->[0];

    my $i = 0;
    while ($i <= $#$node) {
	my $hash = $node->[$i];
	if (defined($hash->{children})) {
	    walkDepthFirst($udf, $udfparam, [ $hash->{children}, @$chain ], $hash);
	}
	if (&$udf($udfparam, $hash, $chain, $i, $parent) == 0) {
	    # delete this item
	    splice(@$node, $i, 1);
	} else {
	    $i++;
	}
    }
}

#------------------------------------------------------------------------------

sub recursiveCopyItem {			# Return a deep copy of an item - recursively
    my $x = shift;
    my ($y, $key, $value);
    if (ref(\$x) eq "SCALAR" || not defined(ref($x))) {
	return $x;
    }elsif (ref($x) eq "SCALAR") {
	$y = $$x; return \$y;
    }elsif (ref($x) eq "ARRAY") {
	$y = [];
	for (@$x) {
	    push @$y, recursiveCopyItem($_);
	}
	return $y;
    }elsif (ref($x) eq "HASH") {
	$y={};
	while (($key,$value) = each %$x) {
	    $$y{$key} = recursiveCopyItem($value);
	}
	return $y;
    }else{
	return $x;
    }
    0;
}

#------------------------------------------------------------------------------

sub hashTreeFromMenu {
    my($base) = shift;
    my($level) = shift;
    my($menu) = shift;
    
    my($entries) = $#$menu;
    my($i) = 0;
    my(@floor) = ();
    my $basepath;

    while ($i <= $entries) {
	my($name, $path, $expand, $upath);
	my(%hash);

	if (ref($menu->[$i]) eq "HASH") {
	    # "Complex form" (inherit variables)
	    my $menuref = $menu->[$i];
	    %hash = %$menuref;
	    if (defined($hash{url})) {
		$upath = $hash{path} = URI->new_abs($hash{url}, $base)->canonical;
		$hash{link} = 1;
	    } else {
		$hash{autoexpand} = 1;
	    }
	} else {
	    ($name,$path) = split(/:/, $menu->[$i], 2);
	    if (defined($path)) {
		$expand = ($path =~ s/^://);
		$hash{forceexpand} = 1 if ($expand);
		$upath = URI->new_abs($path, $base)->canonical;
	    } else {
		$hash{autoexpand} = 1;
		$upath = undef;
	    }
	    $hash{name} = $name;
	    $hash{path} = defined($upath) ? $upath : $base;
	    $hash{link} = 1 if (defined($upath));
	    $hash{hidden} = undef;
	}

	$hash{level} = $level;

	if (defined($upath)) {
	    # Drop fragment
	    if ($upath->fragment) {
		$basepath = substr($upath, 0, -1-length($upath->fragment));
	    } else {
		$basepath = $upath;
	    }
	    $hash{basepath} = $basepath;
	}

	$i++;
	if ($i <= $entries && ref($menu->[$i]) eq "ARRAY") {
	    $hash{children} = hashTreeFromMenu(defined($upath) ? $upath : $base,
				      $level+1, $menu->[$i]);
	    $i++;
	}

	push(@floor, \%hash);
    }
    return \@floor;
}

#------------------------------------------------------------------------------

sub imgsPush {
    my($imgs) = shift;
    my($rel) = shift;
    my($file) = shift;
    my($alt) = shift;

    push(@$imgs, '<IMG src="' . $rel . $ImagePrefix . $file .  $ImageSuffix . '" alt="' . $alt . '"' . $HTMLIMG . '> ');
}

#------------------------------------------------------------------------------

sub imgString {
    my($dir) = shift;	# Directory we operate in
    my($level) = shift;
    my($more) = shift;
    my($parents) = shift;
    my($kids) = shift;

    my($rel) = URI->new($ImageWebRoot)->rel($dir);
    
    if ($ImageIsComposite) {
	my($imgString) =
	    treeString($level, $more, $parents, $kids,
		       "", "", $ImageSpace, $ImageBar, $ImageRight,
		       $ImageEnd, $ImageDown, $ImageLine);
	$treeStrings{$imgString} = 1;
	my($altstring) =
	    treeString($level, $more, $parents, $kids,
		       "", "", $ImageAltSpace, $ImageAltBar, $ImageAltRight,
		       $ImageAltEnd, $ImageAltDown, $ImageAltLine);
	return '<IMG src="' . $rel . $ImagePrefix . $imgString . $ImageSuffix
	    . '" alt="' . $altstring . '"' . $HTMLIMG . '>';
    } else {
	my(@imgs) = ();
	imgsPush(\@imgs, $rel, $ImageSpace, $ImageAltSpace);
	imgsPush(\@imgs, $rel, $ImageBar, $ImageAltBar);
	imgsPush(\@imgs, $rel, $ImageRight, $ImageAltRight);
	imgsPush(\@imgs, $rel, $ImageEnd, $ImageAltEnd);
	imgsPush(\@imgs, $rel, $ImageDown, $ImageAltDown);
	imgsPush(\@imgs, $rel, $ImageLine, $ImageAltLine);
	return treeString($level, $more, $parents, $kids, "", "", @imgs);
    }
}
    
#------------------------------------------------------------------------------

sub treeString {
    my($level) = shift;
    my($more) = shift;
    my($parents) = shift;
    my($kids) = shift;
    # Strings
    my($iPrefix) = shift;
    my($iSuffix) = shift;
    my($iSpace) = shift;
    my($iBar) = shift;
    my($iRight) = shift;
    my($iEnd) = shift;
    my($iDown) = shift;
    my($iLine) = shift;
    # Locals
    my($branch);
    my($i) = 0;
    my($string) = "";

    # Vertical bars for other children of my ancestors
    while ($i < $#$parents) {
	if ($parents->[$i]) {
	    $string .= $iPrefix . $iBar . $iSuffix;
	} else {
	    $string .= $iPrefix . $iSpace . $iSuffix;
	}
	$i++;
    }
    # My own connection to my parents
    if ($more) {
	$string .= $iPrefix . $iRight . $iSuffix;
    } else {
	$string .= $iPrefix . $iEnd . $iSuffix;
    }
    # Branch for my children, if any
    if ($kids) {
	$string .= $iPrefix . $iDown . $iSuffix;
    } else {
	$string .= $iPrefix . $iLine . $iSuffix;
    }
    return $string;
}