#!/usr/bin/perl -w
# Copyright © 2000-2005 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:  4-Nov-00.

require 5;
use diagnostics;
use strict;

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

my $verbose = 0;
my $debug_p = 0;  # this means "don't alter any files, print diffs instead"

my $latest_tag =
  q{^(Redirect 30\d\s+(.*?/backstage/log/)latest\.html\s+[^\s]+\2)([^\n]*)(.*)};

my $title = "DNA Sequencing";
my $columns = 3;
my $margin_left = 10;
my $margin_x = 60;
my $margin_y = 16;

my $xml_link_tag =
  "  <LINK REL=\"alternate\" TYPE=\"application/rss+xml\" TITLE=\"RSS\"" .
         " HREF=\"latest.rss\">\n";



my @menuify_cmd = ("utils/menuify.pl", "utils/template.html");

sub cmp_files($$) {
  my ($file1, $file2) = @_;

  my @cmd = ("cmp", "-s", "$file1", "$file2");
  print "$progname: executing \"" . join(" ", @cmd) . "\"\n" if ($verbose > 2);

  system (@cmd);
  my $exit_value  = $? >> 8;
  my $signal_num  = $? & 127;
  my $dumped_core = $? & 128;
  error ("$cmd[0]: core dumped!") if ($dumped_core);
  error ("$cmd[0]: signal $signal_num!") if ($signal_num);
  return $exit_value;
}


sub diff_files($$) {
  my ($file1, $file2) = @_;

  my @cmd = ("diff", "-Nu2", "$file1", "$file2");
  print "$progname: executing \"" . join(" ", @cmd) . "\"\n" if ($verbose > 1);

  system (@cmd);
  my $exit_value  = $? >> 8;
  my $signal_num  = $? & 127;
  my $dumped_core = $? & 128;

  error ("$cmd[0]: core dumped!") if ($dumped_core);
  error ("$cmd[0]: signal $signal_num!") if ($signal_num);
  return $exit_value;
}


# If the two files differ:
#   mv file2 file1
# else
#   rm file2
#
sub rename_or_delete($$) {
  my ($file, $file_tmp) = @_;

  my $changed_p = cmp_files ($file, $file_tmp);

  if ($changed_p && $debug_p) {
    print STDOUT "\n" . ('#' x 79) . "\n";
    diff_files ("$file", "$file_tmp");
    $changed_p = 0;
  }

  if ($changed_p) {

    if (!rename ("$file_tmp", "$file")) {
      unlink "$file_tmp";
      error ("mv $file_tmp $file: $!");
    }
    print STDERR "$progname: wrote $file\n";

  } else {
    unlink "$file_tmp" || error ("rm $file_tmp: $!\n");
    print STDERR "$progname: $file unchanged\n" if ($verbose > 1);
    print STDERR "$progname: rm $file_tmp\n" if ($verbose > 2);
  }
}


sub build_index($) {
  my ($dir) = @_;

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

  local *LDIR;
  opendir (LDIR, $dir) || error ("$dir: $!");

  my $output = "";

  $output .= "<TITLE>DNA Lounge: $title</TITLE>\n";
  $output .= "<!-- %%RIGHT_START%% -->\n";

  $output .= "  <LINK REL=\"top\"   HREF=\"../../\">\n";
  $output .= "  <LINK REL=\"up\"    HREF=\"../\">\n";
  $output .= $xml_link_tag;

  $output .= "<!-- %%HEADING%% -->\n" .
             "   $title\n\n" .
             "  <P>\n" .
    "\n";

  $output .= "<DIV ALIGN=CENTER>\n";
  $output .= "<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>\n";

  my $col = 0;
  my @years = ();
  foreach my $year (readdir (LDIR)) {
    push @years, $year if ($year =~ m@^\d{4}$@);
  }
  closedir LDIR;
  @years = sort (@years);

  my $rows = int (($#years + $columns) / $columns);

  print STDERR "$progname: $columns x $rows grid of " . ($#years+1) . ".\n"
    if ($verbose > 2);

  my @all_files = ();
  for (my $y = 0; $y < $rows; $y++) {

    if ($y != 0) {
      $output .= " <TR><TD COLSPAN=$columns HEIGHT=$margin_y NOWRAP>" .
                 "</TD></TR>\n";
    }

    $output .= " <TR>\n";
    for (my $x = 0; $x < $columns; $x++) {
      my $year = $years[(($x * $rows) + $y)];
      next unless defined ($year);

      local *YDIR;
      opendir(YDIR, "$dir/$year") || error ("$dir/$year: $!");
      my @files = ();
      foreach my $file (sort (readdir YDIR)) {
        next unless ($file =~ m@^(\d{2})\.html$@);
        my $month = $months[$1 - 1];
        push @files, ("$month $year", "$year/$file");
      }
      closedir YDIR;
      
      # kludge for the prehistoric files...
      if ($year eq '2000') {
        unshift @files, ("1906-1998", "1906-1998.html",
                         "1998-1999", "1998-1999.html");
      }

      if ($x == 0) {
        $output .= " <TD WIDTH=$margin_left NOWRAP></TD>\n";
      } else {
        $output .= " <TD WIDTH=$margin_x NOWRAP></TD>\n";
      }

      $output .= "  <TD ALIGN=RIGHT VALIGN=TOP NOWRAP>";
      #$output .= "<FONT SIZE=\"+1\">";

      for (my $i = 0; $i <= $#files; $i += 2) {
        my $text = $files[$i];
        my $file = $files[$i+1];
        print STDERR "$progname:  $x,$y: $file ==> $text\n" if ($verbose > 2);
        $output .= "<A HREF=\"$file\">$text</A><BR>\n";
        push @all_files, $file;
      }
      #$output .= "</FONT>";
      $output .= "</TD>\n";
    }

    $output .= " <TD WIDTH=$margin_left NOWRAP></TD>\n";
    $output .= " </TR>\n";
  }

  $output .= "</TABLE>\n";
  $output .= "</DIV>\n";
  $output .= "<!-- %%RIGHT_END%% -->\n";

  write_index ($dir, $output);

  @all_files = sort (@all_files);
  update_htaccess ($dir, $all_files[$#all_files]);
}

sub write_index($$) {
  my ($dir, $html) = @_;

  local *OUT;
  my $file = "$dir/index.html";
  my $file_tmp = "$file.tmp";

  open (OUT, ">$file_tmp") || error ("$file_tmp: $!");
  print OUT $html || error ("$file_tmp: $!");
  close OUT;


  my $cd = `pwd`;
  chomp($cd);

#  chdir "../../" || error ("cd ../../: $!");

  my @cmd = @menuify_cmd;
  if ($verbose > 2) {
    push @cmd, ("-" .("v" x ($verbose - 1)));
  }

  my $file_tmp2 = $file_tmp;
  $file_tmp2 = "$cd/$file_tmp";
  $file_tmp2 =~ s@/\./@/@g;
  $file_tmp2 =~ s@^.*/([^/]+/[^/]+/[^/]+)$@$1@;
  push @cmd, $file_tmp2;

  print "$progname: executing \"" . join(" ", @cmd) . "\"\n" if ($verbose > 2);

  system @cmd;
  my $exit_value  = $? >> 8;
  my $signal_num  = $? & 127;
  my $dumped_core = $? & 128;
  error ("$cmd[0]: core dumped!") if ($dumped_core);
  error ("$cmd[0]: signal $signal_num!") if ($signal_num);
  error ("$cmd[0]: exited with $exit_value!") if ($exit_value);

  rename_or_delete ("$file", "$file_tmp");
}

sub update_htaccess($$) {
  my ($dir, $file) = @_;

  my $tag;
  local *IN;
  open (IN, "<$dir/$file") || error ("$dir/$file: $!");
  print STDERR "$progname: reading $dir/$file\n" if ($verbose > 2);
  while (<IN>) {
    if (m@<A\s+NAME\s*=\s*\"([^\"]+)\"@) {
      $tag = $1;
      $tag =~ s/[b-z]$//;
      print STDERR "$progname: saw tag \"$tag\"\n" if ($verbose > 2);
    }
  }
  close IN;

  error ("$file: no entries?") unless defined ($tag);
  print STDERR "$progname: last tag: $file#$tag\n" if ($verbose > 2);
  
  my $redir = "$file\#$tag";

  $file = "$dir/.htaccess";
#  $file = "$dir/../.htaccess" if (! -f $file);
#  $file = "$dir/../../.htaccess" if (! -f $file);
  while ($file =~ m@/[^/.]+/\.\./@) {
    $file =~ s@/[^/.]+/\.\./@/@;
  }

  my $body = "";
  open (IN, "<$file") || error ("$file: $!");

  my $found = 0;
  my $changed = 0;
  while (<IN>) {
    my $line = $_;
    if (m@$latest_tag@s) {
      print STDERR "$progname:  matched: $1 * $3 * $4" if ($verbose > 3);
      $found = 1;
      $_ =~ s/$latest_tag/$1$redir$4/s;
      $changed = ($_ ne $line);
      print STDERR "$progname:  changed: $_" if ($verbose > 3 && $changed);
    }
    $body .= $_;
  }
  close IN;

  if (!$found) {
    print STDERR "$progname: didn't find redirector in $file!\n";
    exit 1;
  }

  if ($changed) {
    local *OUT;
    open (OUT, ">$file") || error ("$file: $!");
    print OUT $body || error ("$file: $!");
    close OUT;
    print STDERR "$progname: wrote $file ($redir)\n" if ($verbose);
  } else {
    print STDERR "$progname: $file unchanged ($redir)\n" if ($verbose > 1);
  }
}


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

sub usage() {
  print STDERR "usage: $progname [--verbose] [--debug] directory\n";
  exit 1;
}

sub main() {
  my $dir;

  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 ($_ eq "--debug")  { $debug_p++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-./) { usage; }
    elsif (!defined($dir)) { $dir = $_; }
    else { usage; }
  }
  usage unless $dir;
  $dir =~ s@/+$@@;
  if (! -d $dir) {
    print STDERR "$progname: directory $dir does not exist\n";
    usage;
  }
  build_index $dir;
}

main();
exit 0;