html-update-toc

#!/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 an 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))
        {
            last;    # past end of file
        }
        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;
            open(my $toc_pipe, '-|', "$script_dir/html-toc", $file)
              or die "Can't run html-toc: $!";
            my $newcontent = do { local $/; <$toc_pipe> };
            close($toc_pipe) or die(
              $! ? "Error closing pipe: $!"
              : "html-toc failed for $file (exit status: $?)"
              );
            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";
}