#!/usr/bin/perl -w
# Copyright © 2000-2008 Jamie Zawinski <jwz@dnalounge.com>.
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# Created: 28-Nov-00.
#
# This script generates/updates the template wrapper and menu contents on
# all of the DNA Lounge pages.  It goes like this:
#
#   - read the target file, and extract the "content" portions of it
#     (the sections between "RIGHT_START and RIGHT_END", etc.)
#   - take the template file, and insert the content into it;
#   - generate a menu for the target file, and splice that in too;
#   - write the result out to the target file.
#
# In this way, we ensure that any changes to the template file always get
# pushed down into every file that uses it.

require 5;
use diagnostics;
use strict;
use bytes;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.60 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

my $verbose = 0;

my $fgcolor    = "#00FF00";
my $bgcolor    = "#000000";
my $head_color = "#004400";
my $bd_color   = "#00EE00";
my $dim_color  = "#666666";

my @menu = ("375 Eleventh Street<BR>\nSan Francisco, CA 94103",
            "  Calendar                calendar/latest.html",
            "  Directions              directions/",
            "  Dinner Menu             kitchen/",
            "  Private Parties         booking/",
            "  Contacting Us           contact/",
            "",
            "  Flyer Archive           flyers/latest.html",
            "  Photo Gallery           gallery/latest.html",
            "  Webcasts                webcast/",
            "  Merchandise             store/",
            "",
            "  Behind the Scenes       backstage/",
            "  What's New              backstage/log/latest.html",
            );

my @months = ("January", "February", "March", "April", "May", "June", "July",
              "August", "September", "October", "November", "December");

# Returns the HTML for the left column menu table for a document living
# at the given URL (really, relative path from the root.)
#
sub make_menu_html($$) {
  my ($current_url, $base) = @_;

  if ($base) {
    error ("base must be an absolute URL: $base")
      unless ($base =~ m@^http://[^/]+/(.*)$@);
    $current_url = $1;
  }

  error ("relative urls only, please: $current_url")
    if ($current_url =~ m@/^http:|^[/.]@);

  $current_url =~ s@\.tmp$@@i;
  $current_url =~ s@/index.s?html?$@/@i;

  my $depth = 0;
  $_ = $current_url;
  while (m@^[^/]+/(.*)$@) {
    $depth++;
    $_ = $1;
  }

  my $prefix;
  if ($base) {
    $prefix = $base;
  } else {
    $prefix = "../" x $depth;
  }

  my $current_indent = 0;
  my $output = "";

  foreach my $item (@menu) {
    $_ = $item;
    my ($indented, $label) = m@^(\s*)(.*)$@s;
    $indented = length($indented) / 2;

    $indented = $current_indent if ($label eq '');  # blank lines

    my $item_url;
    if ($label =~ m@^(.*)( \s+|\t\s*)(.*)$@s) {
      $label = $1;
      $item_url = $3;
      $item_url =~ s/^\s*//;
      $item_url =~ s/\s*$//;

      $item_url = "" if $item_url =~ m@^!@;  # bang means link disabled
    }

    if ($label eq '' && $item_url) {
      error ("blank label with a url?  $item_url");
    }

    $label =~ s/^\s*//;
    $label =~ s/\s*$//;

    if ($indented > $current_indent) {
      if ($current_indent == 0) {
        $output .= " " x ($current_indent * 2);
        $output .= "<P>\n";
      }
      while ($indented > $current_indent) {
        $output .= " " x ($current_indent * 2);
        $output .= "<DIV STYLE=\"margin-left:2em\">\n";
        $current_indent++;
      }
    } elsif ($indented < $current_indent) {
      while ($indented < $current_indent) {
        $current_indent--;
        $output .= " " x ($current_indent * 2);
        $output .= "</DIV>\n";
      }
      if ($current_indent == 0) {
        $output .= " " x ($current_indent * 2);
        $output .= "<P>\n";
      }
    }

    $output .= " " x ($current_indent * 2);

    my $expanded_item_url = expand_latest_url ($item_url, $current_url);

    if (!defined($item_url)) {
      if ($label eq '') {
        $output .= "<BR>\n";
      } else {
        $output .= "<B>$label</B><BR>\n";
      }
    } elsif ($expanded_item_url eq $current_url) {
      $output .= "<B>$label</B><BR>\n";
    } elsif ($item_url eq "") {
      $output .= "<B STYLE=\"color:$dim_color\">$label</B><BR>\n";
    } else {
      $output .= "<A HREF=\"$prefix$item_url\"><B>$label</B></A><BR>\n";
    }
  }

  while ($current_indent > 0) {
    $current_indent--;
    $output .= " " x ($current_indent * 2);
    $output .= "</DIV>\n";
  }

  $output .= "<P>\n";  # at end of menu

  1 while ($output =~ s/<BR>(\s*<P>)/$1/gsi);  # lose BR before P
  1 while ($output =~ s/<P>(\s*<UL>)/$1/gsi);  # lose P before UL
  $output =~ s/^[ \t]*\n//gm;                  # lose blank lines

  $output =~ s/^/\t/gm;   # indent menu

  return $output;
}


# Parse the various .htaccess files to figure out the redirects for
# the "latest" URLs.
#
my %latest_table;
sub load_latest() {
  my @files = (".htaccess", "backstage/log/.htaccess");
  foreach my $file (@files) {
    local *IN;
    if (! open (IN, "<$file")) {
      print STDERR "$progname: $file: $!\n" if ($verbose);
      next;
    }
    while (<IN>) {
      next unless m@^\s*Redirect\s+\d+\s+([^\s]+)\s+([^\s]+)\s*$@;
      my ($from, $to) = ($1, $2);
      $from =~ s@^/@@;
      $to   =~ s@^http://[^/]+/@@;
      $to   =~ s@\#.*$@@;
      $latest_table{$from} = $to;
      print STDERR "$progname: $from => $to\n"
        if ($verbose > 4);
    }
    close IN;
  }
}

# If the URL ends in "latest.html", expand it to the "real" URL.
#
my $latest_loaded_p = 0;
sub expand_latest_url($$) {
  my ($url, $target_url) = @_;
  return $url unless (defined($url));

  if (! $latest_loaded_p) {
    $latest_loaded_p = 1;
    load_latest();
  }

  my $redir = $latest_table{$url};

  if (defined ($redir) && $redir eq $target_url) {
    print STDERR "$progname: latest match: $url => $target_url\n"
      if ($verbose > 3);
    return $target_url;    # this is the target of the "latest" link.
  } else {
    return $url;
  }
}



my %duplicable_keywords;
$duplicable_keywords{HEADING} = 1;
$duplicable_keywords{SUBHEADING} = 1;


# Check to see that only the given set of keywords are in the given text.
# Errors if a keyword is present more than once.  If "demand" is true, 
# errors if any of the keywords are not present.  
# "filename" is only for error messages.
#
sub check_keywords($$$@) {
  my ($filename, $text, $demand, @keywords) = @_;

  my $line = 0;
  my %hits;

  foreach (@keywords) {
    $hits{$_} = 0;
  }

  foreach (split(/\n/, $text)) {
    $line++;
    if (m@<!--\s*%%([^%<>]+)%%\s*-->@) {
      my $k = $1;

      if (!$demand && $k eq "NOWRAP") {
        print "$progname: $filename is NOWRAP: unchanged.\n"
          if ($verbose > 1);
        return 0;
      }

      if (!defined($hits{$k})) {
        error ("$filename: $line: unrecognised keyword: %%$k%%");
      } elsif ($hits{$k} > 1) {
        error ("$filename: $line: duplicate keyword: %%$k%%")
          unless $duplicable_keywords{$k};
      } else {
        $hits{$k}++;
        print STDERR "$progname: $filename: $line: keyword %%$k%%\n"
          if ($verbose > 3);
      }
    }
  }

  if ($demand) {
    foreach (@keywords) {
      if ($hits{$_} == 0 && !$duplicable_keywords{$_}) {
        error ("$filename: missing keyword: %%$_%%");
      }
    }
  }

  return 1;
}



my $template;

sub parse_template_file($) {
  my ($file) = @_;
  local *IN;
  open(IN, "<$file") || error ("$file: $!");
  print STDERR "$progname: reading $file\n" if ($verbose > 2);

  $template = "";
  while (<IN>) { $template .= $_; }
  close IN;

  check_keywords ($file, $template, 1,
                  "HEAD", "TOP", "LEFT", "LEFT2", "RIGHT", "BOTTOM", "MENU",
                  "MENU_HEADER_START", "MENU_HEADER_END",
                  "SUBSCRIBE_HEADER_START", "SUBSCRIBE_HEADER_END",
                  "SUBSCRIBE_MENU_HEADER", "WEBBUG");
}



# Given the body of a file, parse out the data in it and regenerate
# and return the page.
#
#  - anything on the page between %%MENU_START%% and %%MENU_END%%
#    will be replaced with a newly-generated menu;
#
#  - anything inside %%TOP_{START,END}%%, %%LEFT_{START,END}%%,
#    %%RIGHT_{START,END}%%, and %%BOTTOM_{START,END}%% will be
#    preserved in the appropriate place;
#
#  - The presence of %%SUBSCRIBE_MENU_HEADER%% will be noted.
#
#  - everything else will be replaced with the contents of the
#    template file.


sub patch_page_body($$$) {
  my ($filename, $body, $base) = @_;

  return if ($body eq '');
  if (! check_keywords ($filename, $body, 0,
                        "HEAD_START", "HEAD_END",
                        "TOP_START", "TOP_END",
                        "LEFT_START", "LEFT_END",
                        "LEFT2_START", "LEFT2_END",
                        "RIGHT_START", "RIGHT_END",
                        "BOTTOM_START", "BOTTOM_END",
                        "MENU_HEADER_START", "MENU_HEADER_END",
                        "SUBSCRIBE_HEADER_START", "SUBSCRIBE_HEADER_END",
                        "MENU_START", "MENU_END",
                        "SUBSCRIBE_MENU_HEADER",
                        "HEADING", "SUBHEADING",
                        "OVERVIEW_START", "OVERVIEW_END",
                        "UPCOMING_START", "UPCOMING_END",
                        "SNAPSHOTS_START", "SNAPSHOTS_END",
                        "MONTH_FOOTER", "MONTH_LEFT",
                        "XML_STYLESHEET", "XML_FLOATER", "WEBBUG"
                       )) {
    return undef;
  }

  my $new_body = $template;

  # splice in parts of the old file...
  #
  my $got_some = 0;
  foreach my $key ("HEAD", "TOP", "LEFT", "LEFT2", "RIGHT", "BOTTOM") {
    $_ = $body;
    my $val;

    if (m/<!--\s*%% $key _START%%\s*-->(.*)<!--\s*%% $key _END%%\s*-->/xs) {
      $val = $1;
      $val =~ s/^\s+//s;
      $val =~ s/\s+$//s;

      $val .= "\n" unless ($val eq "");

      $got_some++ if ($key =~ m/RIGHT|BOTTOM/);

      print STDERR "$progname: $filename: patched %%$key%%\n"
        if ($verbose > 3);
    } else {
      $val = "";
      print STDERR "$progname: $filename: no %%$key%% keyword\n"
        if ($verbose > 3);
    }

    $val = "<!-- %%${key}_START%% -->\n" . $val . "<!-- %%${key}_END%% -->";
    $new_body =~ s/<!--\s*%%$key%%\s*-->/$val/;
  }

  error ("no RIGHT or BOTTOM tags in $filename?") unless $got_some;

  # If the file asked for the subscribe menu, then delete the menu header
  # from the template (leaving the subscribe header template.)
  # Otherwise, delete the subscribe header from the template (leaving
  # the menu header.)
  #
  my $subscribe_p = ($body =~ m/<!--\s*%%SUBSCRIBE_MENU_HEADER%%\s*-->/);
  my $delete_which = ($subscribe_p ? "MENU" : "SUBSCRIBE");
  my $repl = ($subscribe_p ? "<!-- %%SUBSCRIBE_MENU_HEADER%% -->" : "");
  $new_body =~ s/(<!--\s*%% $delete_which _HEADER_START%%\s*-->)
                 (.*)
                 (<!--\s*%% $delete_which _HEADER_END%%\s*-->)\n*
                //xs;
  print STDERR "$progname: $filename: deleted %%${delete_which}_HEADER%%\n"
    if ($verbose > 3);


  # Construct a new menu, and splice it in.
  #
  my $menu = make_menu_html ($filename, $base);
  $new_body =~ s/(<!--\s*%%MENU%%\s*-->)
                /<!--\ %%MENU_START%%\ -->\n$menu<!--\ %%MENU_END%%\ -->/x;
  print STDERR "$progname: $filename: patched %%MENU%%\n"
    if ($verbose > 3);

  $_ = $body;
  my ($title) = m@<TITLE>(.*)</TITLE>@si;
  if ($title) {
    $new_body =~ s@(<TITLE>)(.*)(</TITLE>)@$1$title$3@si;
    print STDERR "$progname: $filename: patched <TITLE>\n" if ($verbose > 3);
  } else {
    print STDERR "$progname: $filename: no <TITLE>\n" if ($verbose > 3);
  }

  # The only META tag that can appear in documents is this one.
  # Any other META tags must be in the template.
  #
  my ($refresh) = m@(<META\s+HTTP-EQUIV="Refresh"[^<>]+>)@si;
  if ($refresh) {
    $new_body =~ s@(<HEAD>[\t ]*\n)([\t ]+)@$1$2$refresh\n$2@si;
    print STDERR "$progname: $filename: patched <META refresh>\n"
      if ($verbose > 3);
  } else {
    print STDERR "$progname: $filename: no <META refresh>\n"
      if ($verbose > 3);
  }

  # splice in ../../../ to get to images, etc...
  #
  my $depth = 0;

  if ($base) {
    error ("MENUBASE HREF must be an absolute URL: $base")
      unless ($base =~ m@^http://[^/]+/(.*)$@);
    $_ = $1;
  } else {
    $_ = $filename;
  }

  while (m@^[^/]+/(.*)$@) {
    $depth++;
    $_ = $1;
  }

  my $prefix;
  if ($base) {
    $prefix = $base;
  } else {
    $prefix = "../" x $depth;
  }

  # template-ize the tables that we use for headings
  #
  my ($prev_url, $next_url);
  ($new_body, $prev_url, $next_url) =
    handle_heading_table ($filename, $new_body, $prefix);


  $new_body =~ s/%%ROOT%%/$prefix/g;
  print STDERR "$progname: $filename: patched %%ROOT%%\n" if ($verbose > 3);


  # now store the MENUBASE HREF in the file, for next time
  #
  if ($base) {
    my $b = "<MENUBASE HREF=\"$base\">";
    if (! ($new_body =~ s@(</TITLE>)(\s*)@$1$2$b$2@i)) {
      error ("$filename: unable to store MENUBASE after TITLE?");
    }
    print STDERR "$progname: $filename: patched MENUBASE HREF\n"
      if ($verbose > 3);
  }


  # Now handle <LINK> tags
  #
  {
    my ($tlinks) = ($new_body =~ m@([ \t]*(<LINK\b[^<>]+>\s*)+)@si);
    my ($links)  = ($body     =~ m@([ \t]*(<LINK\b[^<>]+>\s*)+)@si);
    $tlinks = '' unless defined ($tlinks);
    $links  = '' unless defined ($links);

    $links =~ s/[ \t]+$//mg;
    $links =~ s/\n+$//sg;
    $tlinks =~ s/[ \t]+$//mg;
    $tlinks =~ s/\n+$//sg;

    # Auto-generate/correct the LINK tags in backstage/log/
    #
    if (defined ($prev_url) && !($prev_url =~ m@\./?$@)) {
      $links .= "\n  <LINK REL=\"prev\"  HREF=\"$prev_url\">";
    }
    if (defined ($next_url) && !($next_url =~ m@\./?$@)) {
      my $latest = ($filename =~ m@\d{4}\.html$@
                    ? "latest.html"
                    : "../latest.html");
      $links .= "\n  <LINK REL=\"next\"  HREF=\"$next_url\">";
      $links .= "\n  <LINK REL=\"last\"  HREF=\"$latest\">"
    }

    my $index_p = ($filename =~ m@(^|/)(index|header)\.html(\.tmp)?$@);

    # update where the "up" link points based on the file name.
    #
    {
      my $log_p = ($filename =~ m@backstage/log/\d{4}/\d\d\.html@);
      $links =~ m@\"up\"\s+HREF=\"([^\"]+)\"@i;
      my $old_up = $1;
      my $new_up = (!$old_up || ($old_up =~ m@^[./]*$@)
                    ? (($index_p || $log_p)
                       ? "../"
                       : "./")
                    : $old_up);
      $tlinks .= "\n  <LINK REL=\"up\"    HREF=\"$new_up\">";
    }

    # keep the links in the order seen, but let the ones in the target file
    # override the ones in the template file.
    #
    my %links_table;
    my @keys = ();
    foreach (split ("\n", $tlinks),
             split ("\n", $links)) {
      my ($key) = m/REL=\"([^\"]+)\"/i;
      error ("$filename: bad juju in LINK tag: $_") unless defined ($key);
      my $old = $links_table{$key};

      if (defined ($old)) {
        if ($_ eq $old) {
          print STDERR "$progname: $filename: dup: $_\n"
            if ($verbose > 4);
        } else {
          print STDERR "$progname: $filename: NEW: $_\n"
            if ($verbose > 3);
          $links_table{$key} = $_;
        }
      } else {
        $links_table{$key} = $_;
        push @keys, $key;
        print STDERR "$progname: $filename: new: $_\n"
          if ($verbose > 4);
      }
    }

    $links = '';
    foreach my $key (@keys) {
      my $val = $links_table{$key};
      $links .= "$val\n";
      print STDERR "$progname: $filename: ==>  $val\n"
        if ($verbose > 4);
    }

    if ($prefix eq '' && $index_p) {
      # no "Top" or "Up" on root page.
      $links =~ s@^\s*<LINK\s+REL=\"(top|up)\"[^<>]+>\s*\n@@gmi;
      print STDERR "$progname: $filename: deleting root \"top\" and \"up\"\n"
        if ($verbose > 4);
    }

    $links =~ s/[ \t]+$//mg;
    $links =~ s/\n+$//sg;
    $links =~ s/^\n//mg;

    $new_body =~ s@^[ \t]*<LINK\b[^<>]+>[\t ]*\n@@mig;
    $new_body =~ s@(\n[ \t]*</HEAD)@\n$links$1@si;

    print STDERR "$progname: $filename: patched <LINK>\n" if ($verbose > 3);
  }

  # fix up extra blank-line insertion stupidity
  $new_body =~ s/\n\n\n+/\n\n/gs;

  return $new_body;
}


# Do the special-case magic to emit all the HTML marked by:
# %%HEADING%%, %%SUBHEADING%%, %%MONTH_FOOTER%%, and %%MONTH_LEFT%%.
# These are all big hairy tables, some with navigation links in them.
#
# Returns: "new_body", "prev_url" (or undef), "next_url" (or undef)
#
sub handle_heading_table($$$) {
  my ($filename, $body, $prefix) = @_;

  my $subheading_count = 0;
  my $last_subheading = '';
  my ($purl, $nurl);

  my $new_body = "";
  while ($body =~ m@^(.*?<!--
                      \s*%%(HEADING|SUBHEADING|MONTH_FOOTER|MONTH_LEFT|
                            XML_STYLESHEET|XML_FLOATER|WEBBUG)
                      %%\s*-->\s*)(.*)$@sx) {
    $new_body .= $1;
    my $tag = $2;
    $body = $3;
    my $heading_p = ($tag =~ m/HEADING/);
    my $subheading_p = ($heading_p && $tag =~ m/SUBHEADING/);

    $_ = $new_body;
    my ($indent) = m/([ \t]*)$/s;
    $new_body =~ s/[ \t]*$//s;  # delete spaces at beginning of heading line

    $_ = $body;
    if ($heading_p) {
      m@^(.*?)(\n\s*\n.*)@s ||
        error ("$filename: no blank line after %%$tag%% block?");

      my $heading = $1;
      $body = $2;

      my $text = $heading;
      1 while ($text =~ s@<[^<>]+>@@g);
      $text =~ s/^\s*(\&(nbsp|times);\s*)+//; # "magic bullet"
      $text =~ s/\s*(\&nbsp;\s*)+$//; # trailing nbsps
      $text =~ s/\s\s+/ /gs;
      $text =~ s/^\s+//gs;
      $text =~ s/\s+$//gs;

      if ($subheading_p) {

        my $name = $text;
        $name =~ s/\(.*\)//g;
        $name =~ s/^\s+//g;
        $name =~ s/\s+$//g;
        $name =~ s/\s+/-/g;
        $name =~ tr/A-Z/a-z/;

        $name =~ s/^(\d\d\d)\d\?$/$1x/; # "1940?" ==> "194x"

        # kludge for the flag day when I changed the anchor format in
        # the log.
        #
        my $oldname = undef;
        if ($name =~ m/^(\d{1,2})-([a-z]{3})-(\d{4})$/i) {
          my ($dotm, $month, $year) = ($1, $2, $3);
          if (! ($year > 2003 ||
                 ($year == 2003 &&
                  (!($month =~ m/Jan/i) || $dotm >= 12)))) {
            $oldname = $name;
          }
          $name = sprintf ("%02d", $dotm);
        }

        if ($name eq $last_subheading) {
          print STDERR "$filename: subheading dup: $name => ${name}b\n"
            if ($verbose > 2);
          $name .= "b";
        }
        $last_subheading = $name;

        print STDERR "$filename: subheading: $name / $text\n"
          if ($verbose > 2);

        $heading = 
          ("<B CLASS=\"sbox\">" .
            "<A NAME=\"$name\" HREF=\"\#$name\" CLASS=\"plink\">" .
              "&times;" .
            "</A> &nbsp;\n" .
            ($oldname ? "<A NAME=\"$oldname\">" : "") .
            "$text" .
            ($oldname ? "</A>" : "") .
           "</B><UL>");

        $subheading_count = 0      # reset when we move from RIGHT to BOTTOM
          if ($new_body =~ m/<!--\s%%BOTTOM_START%%\s-->\s*
		             <!--\s%%SUBHEADING%%\s-->\s*
                             $/isx);

        $heading = "</UL>$heading" if ($subheading_count > 0);
        $subheading_count++;

      } else {

        print STDERR "$filename: heading: $text\n" if ($verbose > 2);

        $heading = 
          ("<DIV ALIGN=CENTER>" .
            "<B CLASS=\"gbox\">" .
             $text .
            "</B>" .
           "</DIV>" .
           "<P>\n");
      }

      $heading =~ s/^/$indent/gm;

      $new_body .= $heading;

    } elsif ($tag =~ m/XML_STYLESHEET/) {

      m@^(.*?/STYLE>\n?)(.*)$@s ||
        error ("$filename: no /STYLE line after %%$tag%% block?");

      my $stylesheet = $1;
      $body = $2;

      $stylesheet =
        ("<STYLE TYPE=\"text/css\">\n" .
         "<!--\n" .
         ".xml_button {\n" .
         " color: #FFF;\n" .
         " background: #F60;\n" .
         " text-decoration: none;\n" .
         " padding: 0 0.5em;\n" .
         " border: 2px outset #F60;\n" .
         " font-size: x-small;\n" .
         " font-weight: bold;\n" .
         "}\n" .
         ".xml_button:hover { background: #F90; }\n" .
         ".xml_button:active { border-style: inset; }\n" .
         "-->\n" .
         "</STYLE>\n");

      $stylesheet =~ s/^/$indent/gm;
      $new_body .= $stylesheet;

    } elsif ($tag =~ m/XML_FLOATER/) {

      m@^(.*?</SPAN>\n?)(.*)$@s ||
        error ("$filename: no /SPAN line after %%$tag%% block?");

      my $table = $1;
      $body = $2;

      $table = ("<SPAN STYLE=\"float:right\">\n" .
                " <A HREF=\"${prefix}xml/\" CLASS=\"xml_button\">RSS</A>\n" .
                "</SPAN>\n");

      $table =~ s/^/$indent/gm;
      $new_body .= $table;

    } elsif ($tag =~ m/WEBBUG/) {

      m@^(<SCRIPT\b [^<>]*> \s* </SCRIPT> \s*
          <SCRIPT\b [^<>]*> [^<>]* </SCRIPT>
         )? \s*
         (.*)@sx ||
        error ("$filename: no SCRIPT tags after %%$tag%% block?");

      my $script = $1;
      $body = $2;

      my $id = "UA-2574834-4";
      $script = ("<SCRIPT SRC=\"http://www.google-analytics.com/ga.js\"\n" .
                 " TYPE=\"text/javascript\"></SCRIPT>\n" .
                 "<SCRIPT LANGUAGE=\"JavaScript\">\n" .
                 " var tt = _gat._getTracker(\"$id\");\n" .
                 " tt._initData();\n" .
                 " tt._trackPageview();\n" .
                 "</SCRIPT>\n");

      $new_body .= $script;

    } else {   # MONTH_FOOTER or MONTH_LEFT

      my $footer_p = ($tag =~ m/FOOTER/);

      m@^(.*?/TABLE>\n(\s*<(P|BR)>)*)(.*)$@s ||
        error ("$filename: no /TABLE line after %%$tag%% block?");

      my $heading = $1;
      $body = $4;

      my ($mon, $pmon, $nmon);

      # Handle files in the backstage/log/YYYY/ directories...
      #
      if ($filename =~ m@^(.*/)(\d{4})/(\d\d)z?(\.html|/?)$@s) {
        my ($prefix, $year, $suffix);
        ($prefix, $year, $mon, $suffix) = ($1, $2, $3, $4);
        my $lyear = $year;
        my $nyear = $year;
        $pmon = $mon-1;
        $nmon = $mon+1;
        if ($pmon == 0)  { $pmon = 12; $lyear--; }
        if ($nmon == 13) { $nmon = 1;  $nyear++; }

        $purl = (($lyear == $year ? "" : "../$lyear/") .
                 sprintf("%02d$suffix", $pmon));
        $nurl = (($nyear == $year ? "" : "../$nyear/") .
                 sprintf("%02d$suffix", $nmon));

        $mon  = $months[$mon-1];  $mon  =~ tr/A-Z/a-z/;
        $pmon = $months[$pmon-1]; $pmon =~ tr/A-Z/a-z/;
        $nmon = $months[$nmon-1]; $nmon =~ tr/A-Z/a-z/;

        if (! -f "$prefix$year/$purl") {
          if ($filename =~ m@backstage/log/2000/03\.html@) {
            $purl = "../1998-1999.html";
            $pmon = "1998-1999";
            $mon .= " $year";
          } else {
            error ("don't know how to link to nonexistent $prefix$year/$purl");
          }
        }

        if (! -f "$prefix$year/$nurl") {
          $nurl = "../";
          $nmon = "top";
        }

      # Handle the two ancient-history files in the backstage/log/ directory...
      #
      } elsif ($filename =~ m@^(.*/)(\d{4})-(\d{4})(\.html|/?)$@s) {
        my ($prefix, $y1, $y2, $suffix) = ($1, $2, $3, $4);

        if ($y1 == 1998) {
          $mon = "";
          $pmon = "1906-1998";
          $purl = "$pmon.html";
          $nmon = "2000";
          $nurl = "$nmon/03.html";

        } elsif ($y1 == 1906) {
          $mon = "";
          $pmon = "top";
          $purl = "./";
          $nmon = "1998-1999";
          $nurl = "$nmon.html";

        } else {
          error ("%%$tag%% in unparsable magic filename: $filename");
        }

      } else {
        error ("%%$tag%% in unparsable filename: $filename");
      }

      if ($footer_p) {
        $heading =
          ("<P><BR CLEAR=ALL>\n" .
           "<TABLE CLASS=\"noprint\" WIDTH=\"100%\" " .
              "CELLPADDING=2 CELLSPACING=0 BORDER=0>\n" .
           " <TR STYLE=\"color: #000; background:#0E0; " .
                        "font-size:larger; font-weight:bold\">\n".
           "  <TD NOWRAP ALIGN=LEFT WIDTH=\"33%\">\n" .
           "   <A HREF=\"$purl\" STYLE=\"color:#000\">&lt;&lt; $pmon</A>" .
             "</TD>\n" .
           "  <TD NOWRAP ALIGN=CENTER WIDTH=\"34%\">$mon" .
             "</TD>\n" .
           "  <TD NOWRAP ALIGN=RIGHT WIDTH=\"33%\">\n" .
           "   <A HREF=\"$nurl\" STYLE=\"color:#000\">$nmon &gt;&gt;</A>" .
             "</TD>\n" .
           "  </TR>\n" .
           "</TABLE>\n");
      } else {

        $mon  =~ s/^(...).*$/\u$1/ unless ($mon  =~ m/^\d/);
        $pmon =~ s/^(...).*$/\u$1/ unless ($pmon =~ m/^\d/);
        $nmon =~ s/^(...).*$/\u$1/ unless ($nmon =~ m/^\d/);

        $heading =
          ("<P>\n" .
           "<TABLE BORDER=0 CELLPADDING=4 CELLSPACING=0 WIDTH=\"100%\">\n" .
           " <TR>\n" .
           "  <TD NOWRAP ALIGN=LEFT VALIGN=TOP WIDTH=\"33%\">\n" .
           "   <A HREF=\"$purl\"><B>&lt;&lt; $pmon</B></A></TD>\n" .
           "  <TD NOWRAP ALIGN=CENTER VALIGN=TOP WIDTH=\"34%\">\n" .
           "   <B>$mon</B></TD>\n" .
           "  <TD NOWRAP ALIGN=RIGHT VALIGN=TOP WIDTH=\"33%\">\n" .
           "   <A HREF=\"$nurl\"><B>$nmon &gt;&gt;</B></A></TD>\n" .
           " </TR>\n" .
           "</TABLE>\n" .
           "<P><BR>\n");
      }

      $new_body .= $heading;
    }
  }

  $new_body .= $body;  # pick up tail of file

  return ($new_body, $purl, $nurl);
}



sub patch_page($$$) {
  my ($file, $base, $validate_p) = @_;
  
  $file =~ s@^\./@@;  # take off leading "./"

  local *IN;
  open(IN, "<$file") || error ("$file: $!");
  print STDERR "$progname: reading $file\n" if ($verbose > 2);
  my $body = "";
  while (<IN>) { $body .= $_; }
  close IN;

  if ($body =~ m@<MENUBASE\s+HREF=\"([^\"]+)\"@i) {
    $base = $1;
  }

  my $body2 = patch_page_body ($file, $body, $base);

  validate_html ($file, $body2 || $body) if ($validate_p);

  return unless defined($body2);

  if ($body ne $body2) {
    local *OUT;
    my $file_tmp = "$file.tmp";
    open(OUT, ">$file_tmp") || error ("$file_tmp: $!");
    print OUT $body2 || error ("$file_tmp: $!");
    close OUT;

    if (!rename ("$file_tmp", "$file")) {
      unlink "$file_tmp";
      error ("mv $file_tmp $file: $!");
    }

    print STDERR "$progname: wrote $file\n" if ($verbose);

  } elsif ($verbose) {
    print STDERR "$progname: $file: unchanged\n" if ($verbose > 1);
  }
}


# The HTML validator generates an error if we use a tag that isn't
# in this list (in order to detect typos.)
# Mostly duplicated in calendar/generate-calendar.pl
#
my %allowed_tags = (
 "A" => 1, "AREA" => 2, "B" => 1, "BASE" => 2, "BLOCKQUOTE" => 1,
 "BODY" => 1, "BR" => 2, "DD" => 1, "DIV" => 1, "DL" => 1, "DT" => 1,
 "FONT" => 1, "FORM" => 1, "H1" => 1, "H2" => 1, "H3" => 1, "HEAD" => 1,
 "HR" => 2, "HTML" => 1, "I" => 1, "IMG" => 2, "INPUT" => 2, "LI" => 1,
 "LINK" => 2, "MAP" => 1, "MENUBASE" => 2, "META" => 2, "NOBR" => 1,
 "NOSCRIPT" => 1, "OL" => 1, "OPTION" => 1, "P" => 2, "PRE" => 1,
 "SCRIPT" => 1, "SELECT" => 1, "SPAN" => 1, "STRIKE" => 1, "STYLE" =>1,
 "SUP" => 1, "TABLE" => 1, "TD" => 1, "TH" => 1, "TITLE" => 1, "TR" => 1,
 "TT" => 1, "U" => 1, "UL" => 1, "WBR" => 2,
 "EMBED" => 1,
);


# Does some simple syntax-checking on the HTML: makes sure tags are
# balanced, etc.
# Mostly duplicated in calendar/generate-calendar.pl
#
sub validate_html($$) {
  my ($filename, $html) = @_;

  my $lineno = 1;
  my @stack = ();
  my $debug = 0;

  # Kludge for doctype: turn it into a comment.
  #
  $html =~ s@^(\s*<!DOCTYPE\b[^<>]*>)@<!-- $1 -->@s;

  # lose text inside comments (but keep the newlines, for line numbering)...
  #
  $html =~ s@(<!--)(.*?)(-->)@{ my ($a, $b, $c) = ($1, $2, $3);
                                $b =~ s/^.*$//gm;
                                "$a$b$c";
                              }@gse;
  $html =~ s/(<!--|-->)//g;  # lose comment tags themselves

  $html =~ s/\n/\n\001/gs;
  $html =~ s/</\n</gs;
  print STDERR "\nVALIDATE: $filename:\n" if ($debug);
  foreach (split ("\n", $html)) {
    if (m/^\001/) {
      $lineno++;
      next;
    }
    my ($tag) = m/^<([^<>\s]+)/;

    next unless defined ($tag);
    $tag =~ tr/a-z/A-Z/;

    $tag = 'P' if ($tag eq '/P');    # kludge...

    my $code = $allowed_tags{$tag};

    if ($tag =~ m@^/@) {      # closing a tag
      my $otag = pop @stack;
      print STDERR "$lineno: POP  " . ('. ' x ($#stack+1)) . "/$otag\n"
        if ($debug);
      if (!defined ($otag)) {
        error ("$filename: $lineno: extranious <$tag>");
      } elsif ($tag ne "/$otag") {
        my $t2 = $tag; $t2 =~ s@^/@@;
        $code = $allowed_tags{$t2};
        if ($code && $code == 2) {
          error ("$filename: $lineno: unexpected close-tag form: <$tag>");
        } else {
          error ("$filename: $lineno: <$otag> closed by <$tag>");
        }
      }

    } elsif (! $code) {
      error ("$filename: $lineno: unknown tag <$tag>");

    } else {

      my $otag = $stack[$#stack] || '';
      if (($tag eq 'TD' && $otag ne 'TR') ||
          ($tag eq 'TH' && $otag ne 'TR') ||
          ($tag eq 'TR' && $otag ne 'TABLE') ||
          ($otag eq 'TR' && $tag ne 'TD' && $tag ne 'TH') ||
          ($otag eq 'TABLE' && $tag ne 'TR') ||
          ($otag eq 'OPTION' && $tag eq 'OPTION') ||
          ($otag eq 'LI' && $tag eq 'LI')
         ) {
        error ("$filename: $lineno: <$tag> not allowed inside <$otag>");
      }

      if ($code == 2) {
        # ignore these -- don't insist on closing tags.

        print STDERR "$lineno: SKIP " . ('. ' x ($#stack+1)) . "$tag\n"
          if ($debug);

      } else {  # opening a new tag
        print STDERR "$lineno: PUSH " . ('. ' x ($#stack+1)) . "$tag\n"
          if ($debug);
        push @stack, $tag;
      }
    }
  }

  if ($#stack >= 0) {
    error ("$filename: $lineno: unclosed tags: <" .
           join (">, <", @stack) . ">");
  }
}


sub error($) {
  my ($err) = @_;
  print STDERR "$progname: $err\n";
  exit 1;
}

sub usage() {
  print STDERR "usage: $progname [--verbose] [--validate] " .
    "template-file [ files-to-update...]\n";
  exit 1;
}

sub main() {

  my $template_file;
  my @target_files;
  my $base = undef;
  my $validate_p = 0;

  error ("LANG is $ENV{LANG} -- UTF is no good, man!")
    if ($ENV{LANG} && $ENV{LANG} =~ m/utf/i);

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif ($_ eq "--base") { $base = shift @ARGV; }
    elsif ($_ eq "--validate") { $validate_p++; }
    elsif (m/^-./) { usage; }
    elsif (!defined($template_file)) { $template_file = $_; }
    else { push @target_files, $_; }
  }

  usage unless defined($template_file);
  usage unless ($#target_files >= 0);

  parse_template_file ($template_file);
  foreach my $f (@target_files) {
    patch_page ($f, $base, $validate_p);
  }
}

main();
exit 0;