#!/usr/bin/env perl
# html-update-toc
# Update (in place) table of contents for an HTML document.
# Michael Ernst <mernst@cs.washington.edu>
# Time-stamp: <2020-12-24 11:03:07 mernst>

# This script edits a HTML file in place to modify an existing table of
# contents.  The contents start with
#   <!-- start toc -->
# and end with
#   <!-- end toc -->
# There may be extra text in the comments; for example,
#   <p>Contents:</p>
#   <!-- start toc.  do not edit; run html-update-toc instead -->
#   <!-- end toc -->
# To get started, just add those three lines near the top of the file.

# The table of contents contains links to header lines of these forms:
#   <h3 id="key">Subheading</h3>
#   <h3><a name="key">Subheading</a></h3>
# Header lines without "id=..." or "<a name=...>" anchor tags are ignored
# (and a warning is generated).  The header opening and closing tags (e.g.,
# <h3> and </h3>) should appear on the same line.
# Header lines are omitted if they contain
#   <!-- omit from toc -->
# For instance, this would not appear:
#   <h1>The title of the document</h1>                  <!-- omit from toc -->

# This script does not fully parse the HTML document; instead, it
# pattern-matches against specific lines in the document.  That means that
# it will generate table-of-contents lines for commented-out sections of a
# document.  To ensure that a header line doesn't appear in the table of
# contents, start a comment on that line, such as:
#   <!-- <h2>...</h2>  ...


# As noted above, header lines should contain anchor tags.
# Here is Emacs code to add anchor names:
#   (defun html-add-heading-anchors ()
#     "Add anchors to section headings in an HTML document."
#     (interactive)
#     (require 'dired)
#     (save-excursion
#       (goto-char (point-min))
#       (while (re-search-forward "^\\(<h[1-6]\\)\\([^>]*>\\)\\([^<>\n]+\\)\\(</h[1-6]>\\)[ \t]*" nil t)
#         (let ((hextra (match-string 2))
#               (hname (match-string 3)))
#           (if (not (save-match-data (string-match " id=" hextra)))
#               (let ((anchor-name
#                      (save-match-data (dired-replace-in-string " " "_"
#                                         (dired-replace-in-string "'" "" hname)))))
#                 (replace-match (concat " id=\"" anchor-name "\"" hextra) nil t nil 2)))))))


use strict;
use English;
$WARNING = 1;

my $debug = 0;
# $debug = 1;

my $quiet = 0;

use File::Basename;
my $script_dir = dirname(__FILE__); # directory name of this script

# Read by paragraphs (remember that this is a string, not a regexp).
# (Warning: this doesn't work for DOS files, but I hack around that via
# the $contents_end regexp.)
# (Also, when paragraphs are separated by more than 2 newlines, this makes
# Perl treat the input as if it contains some empty paragraphs.)
$INPUT_RECORD_SEPARATOR = "\n\n";

# TODO:
# These regexps support backward compatibility; they can be simplified.
my $contents_start = "<!-- (?:start )?(?:toc|contents)\\b[^>]*-->(?:\r?\n)?|(?:Table of )?Contents:[ \t]*(?:<!-- auto-generated by html-toc -->|<!-- do not edit; run html-update-toc -->)(?:\r?\n)?";
# Second alternative used to be "\r?\n$" to avoid grabbing too much DOS text.
my $contents_end = "<!-- end (?:toc|contents)\\b[^>]*-->|</?p>([ \t]*<!-- auto-generated by html-toc -->\r?\n|\r?\n)";
my $contents_start_quoted = $contents_start;
$contents_start_quoted =~ s/\n/\\n/g;
$contents_start_quoted =~ s/\r/\\r/g;
my $contents_end_quoted = $contents_end;
$contents_end_quoted =~ s/\n/\\n/g;
$contents_end_quoted =~ s/\r/\\r/g;

FILELOOP: for my $file (@ARGV) {
  if ($debug) { print STDERR "Examining $file\n"; }
  if (($file eq "-q") || ($file eq "--quiet") || ($file eq "-quiet")) {
    $quiet = 1;
    next;
  }
  if ($file !~ /\.html?$/) {
    if ($debug) { print STDERR "Skipping $file:  does not end in .htm or .html\n"; }
    next;
  }
  if (! open(FILE, $file)) {
    print STDERR "Skipping $file:  can't open\n";
    next;
  }
  # Only check the first 10 paragraphs (see above for caveat).
  for (my $i=0; $i<10; $i++) {
    my $line = <FILE>;
    if (! defined($line)) {
      # past end of file
      next;
    }
    if ($debug) { print STDERR "line: $line"; }
    # ".*?" means a minimal match
    if ($debug) { print "matches start? " . ($line =~ /$contents_start/) . "\n"; }
    if ($debug) { print "matches end? " . ($line =~ /$contents_end/) . "\n"; }
    if ($line =~ /($contents_start)(.*?)($contents_end)/is) {
      my $oldcontent = $2;
      my $newcontent = `$script_dir/html-toc $file`;
      if ($newcontent eq "\n") {
        $newcontent = "";
      }
      if ($oldcontent eq $newcontent) {
        if (! $quiet) {
          print STDERR "$file has up-to-date table of contents\n";
        }
        close(FILE);
        next FILELOOP;
      }
      close(FILE);

      if (! $quiet) {
        print STDERR "html-update-toc: updating $file\n";
      }

      # I would like to just call Perl with
      #   "perl -pi.bak -e '\$/ = \"\\n\\n\"; s/($contents_start_quoted)(.*?)($contents_end_quoted)/\$1$newcontent_quoted\$3/s'"
      # but that doesn't work:  the shell says "word too long".
      rename($file,"$file.bak") or die "Can't make backup of $file";
      open(OLDFILE, "$file.bak") or die "Can't read backup I just made: $file.bak";
      open(FILE, ">$file") or die "Can't write $file; old version in $file.bak";
      while (defined($line = <OLDFILE>)) {
        $line =~ s/($contents_start)(.*?)($contents_end)/$1$newcontent$3/si;
        print FILE $line;
      }
      close(OLDFILE);
      close(FILE);
      unlink("$file.bak");

      # I could now reset the write date, but the file *has* changed,
      # so don't bother.

      next FILELOOP;
    }

  }
  # It's not clear whether this is a helpful warning or is annoying.
  print STDERR "No table of contents found in first 10 paragraphs of $file\n";
}