#!/usr/bin/env perl
# html-toc
# Generate (to standard out) table of contents for an HTML document.
# Michael Ernst <mernst@csail.mit.edu>
# Thanks to C. Scott Ananian <cscott@cscott.net>
# Time-stamp: <2006-04-07 17:24:11 mernst>

# See html-update-toc for documentation.
# (Typically, you will not run this program, but will use html-update-toc
# instead.)

use strict;
use English;
$WARNING = 1;

my $level = 0;
my $num_named_1 = 0;		# number of named items in <h1>...</h1>
my $num_unnamed_1 = 0;		# number of unnamed items in <h1>...</h1>
my $output = "";
my $errors = "";
my $debug = 0;
# $debug = 1;


sub enter_level {
  # called with cursor at start of line.
  $output .= ((" " x ($level * 4)) . "<ul>\n");
  $level++;
  # returns with cursor at start of line.
}

sub exit_level {
  # always called with an open <li>
  $level--;
  $output .= "</li>\n";
  $output .= ((" " x ($level * 4)) . "</ul>");
  # returns with an open <li>
}


# Main loop

while (<>) {
  if (/^<!--/) {
    next;
  } elsif (/<!-- omit from toc -->|<omit from toc>/) {
    # Check <omit from toc> because sometimes, a HTML comment is not appropriate.
    next;
  } elsif (/<h([1-9])>
	   <a   # open the a start tag
	   (?:\s+\w+\s*=\s*\"[^\"]*\")*? # allow random attributes
	   \s+(?:name|id)\s*=\s*\"([^\"]*)\" # look for name or id attribute
	   (?:\s+\w+\s*=\s*\"[^\"]*\")*? # allow random attributes
	   \s*> # close the a start tag
	   (.*?)  # the text of the anchor
	   <\/a> # the a end tag
	   (.*)   # sometimes the anchor text is found here instead
	   <\/h([1-9])>
	   /ix) {
    if ($debug) { print STDERR "match 3: <$1><$2><$3><$4><$5>\n"; }
    if ($1 ne $5) {
      $errors .= "Non-matching heading tags $1 and $5: $_";
    }
    my $thishlevel = $1;
    my $anchorname = $2;
    my $secname1 = $3;
    my $secname2 = $4;
    # Remove leading and trailing whitespace in section title.
    $secname1 =~ s/^[ \t]+//;
    $secname1 =~ s/[ \t]+$//;
    $secname2 =~ s/^[ \t]+//;
    $secname2 =~ s/[ \t]+$//;
    my $sectitle = $secname1;
    if ($sectitle eq "") {
      $sectitle = $secname2;
    }

    if (($secname1 ne "") && ($secname2 ne "")) {
      $errors .= "Duplicate section title: $_";
      next;
    }

    # if $level >= $thishlevel, we have an open <li>
    while ($level > $thishlevel) {
      exit_level();
    }
    # close this <li>, unless we're going deeper
    $output .= "</li>" if ($level == $thishlevel);
    $output .= "\n" unless $level == 0;
    while ($level < $thishlevel) {
      enter_level();
      $output .= (" " x ($level * 4 - 2)) . "<li>\n" if $level < $thishlevel;
    }
    $output .= ((" " x ($level * 4 - 2)) . "<li><a href=\"#$anchorname\">$sectitle</a>");
    if ($level == 1) { $num_named_1++; }
  } elsif (/<h([1-9])>(.*)<\/h([1-9])>/) {
    if ($1 == 1) {
      $num_unnamed_1++;
    }
    $errors .= "$ARGV:$.: No <a name=...> tag: $_";
  } elsif (/<h([1-9])>/) {
    $errors .= "$ARGV:$.: No </h$1> tag: $_";
  }
} continue {
  # Reset line numbers; example from "eof" text in "man perlfunc".
  close ARGV  if eof;     # Not eof()!
}

while ($level > 0) {
  exit_level();
}
$output .= "\n";
if ($num_named_1 + $num_unnamed_1 < 2) {
  # There is only one top-level (<h1>) item.
  # Assume <h1> is the page title, and the h2, h3, h4 etc are the ones
  # we should be making a toc for.
  $output =~ s/^<ul>\n//;
  $output =~ s/<\/ul>\n$//;
  # remove top-level item.
  $output =~ s/^  <li>.*\n//;
  $output =~ s/<\/li>\n$/\n/;
  if ($num_unnamed_1 == 1) {
    # Remove error from output
    $errors =~ s/^.*: No <a name=\.\.\.> tag: <h1>[^\n]*\n//;
  }
}
print STDERR $errors;
print $output;

exit(0);