#!/usr/bin/perl -w
# Copyright © 2002-2007 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.
#
# Generates RSS 0.91 RDF (e.g., for Livejournal) from the What's New journal.
# Created:  8-Jul-2002.
#
# DNA Lounge URL:  http://www.dnalounge.com/backstage/log/latest.rss
# LiveJournal URL: http://www.livejournal.com/users/dnalounge/
# Documentation:   http://my.netscape.com/publish/formats/rss-spec-0.91.html

require 5;
use diagnostics;
use strict;
use POSIX;

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

my $verbose = 0;


my $rss_title      = "DNA Lounge: What's New";
my $rss_desc       = "Behind the scenes at the DNA Lounge, by Jamie Zawinski";
my $rss_lang       = "en";
my $rss_webmaster  = "webmaster\@dnalounge.com";
my $rss_editor     = "jwz\@dnalounge.com";
my $rss_img_title  = "DNA Lounge";
my $rss_img_url    = "http://www.dnalounge.com/logo-thumb.gif";
my $rss_img_width  = 100;
my $rss_img_height = 34;
my $rss_img_link   = "http://www.dnalounge.com/";
my $base_url       = "http://www.dnalounge.com/backstage/log/latest.html";
my $rss_nitems     = 6;


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

  # only keep stuff inside the "right" and "bottom" sections
  #
  {
    $_ = $body;
    my ($b1) = m/^.*<!--\s+%%RIGHT_START%%\s+-->
                (.*)<!--\s+%%RIGHT_END%%\s+-->.*$/sx;
    my ($b2) = m/^.*<!--\s+%%BOTTOM_START%%\s+-->
                (.*)<!--\s+%%BOTTOM_END%%\s+-->.*$/sx;
    error ("$file: unable to find %%RIGHT%% section")  unless defined ($b1);
    error ("$file: unable to find %%BOTTOM%% section") unless defined ($b2);
    $body = "$b1\n$b2";

    # When an entry splits between RIGHT and BOTTOM, the UL is closed
    # and re-opened.  Fix that.
    $body =~ s@(</UL>)(\s*<!--\s+%%SUBHEADING%%\s+-->\n)@$2$1@gsi;
    $body =~ s@</UL>\s*(<P>\s*)?<UL>@<P>@gsi;
  }

  my @sections = split (/<!--\s+%%SUBHEADING%%\s+-->/, $body);

  # lose the text before the first section
  shift @sections;

  # lose the text after the last </UL> in the last section
  $sections[$#sections] =~ s@^(.*)</UL>\n.*?$@$1@s ||
    error ("last section does not end with </UL>");

  my @results = ();

  foreach (@sections) {
    s/^\s+//s;  # lose leading whitespace
    s/\s+$//;  # lose trailing whitespace

    s/^.*?
      <A\s+NAME=\"(\d+b?(-[a-z]+-\d{4})?)\"
      .*?
      (\d+-[a-z]+-\d{4}\s+\([a-z]+\))
      .*?
      \n\n//xsi;

    my ($d1, $d2) = ($1, $3);
    error ("no anchor found?") unless ($d1 && $d2);

    my $title = $d2;
    my $link = "$base_url\#$d1";
    my $desc = expand_urls ($_, $base_url);

    $_ = make_rss_item ($title, $link, $desc);
    unshift @results, $_;

    print STDERR "$progname: parsed $title\n"
      if ($verbose > 1);
  }

  return @results;
}


sub get_items($$$) {
  my ($how_many, $dir, $base_url) = @_;

  local *DIR;

  $dir =~ s@/+$@@;            # take off trailing slash
  $base_url =~ s@/[^/]*$@/@;  # take off trailing file component

  opendir (DIR, "$dir") || error ("$dir: $!");
  my @files = readdir (DIR);
  closedir DIR;

  my @result = ();

  foreach (sort { $b cmp $a } (@files)) {
    next if (m/^\./);
    next unless (m/^\d{4}$/);

    my $year = $_;
    my $dir2 = "$dir/$year";
    opendir (DIR, "$dir2") || error ("$dir2: $!");
    my @files2 = readdir (DIR);
    closedir DIR;

    foreach (sort { $b cmp $a } (@files2)) {
      next if (m/^\./);
      next unless (m/^(\d\d)\.html$/);
      my $name = $_;
      my $file = "$dir2/$name";

      push @result, parse_monthly_html ($file, "$base_url$year/$name");

      if ($#result >= $how_many) {
        @result = @result[0 .. $how_many-1]
          if ($#result > $how_many);
        return @result;
      }
    }
  }

  return @result;
}


sub make_rss($$$$$$$$) {
  my ($title, $link, $desc, $pubdate, $builddate,
      $nitems, $dir, $base_url) = @_;

  my $items = join ('', get_items ($nitems, $dir, $base_url));
  $items =~ s/^/  /gm;

  return ("<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" .
          "<!DOCTYPE rss PUBLIC " .
          "\"-//Netscape Communications//DTD RSS 0.91//EN\" " .
          "\"http://my.netscape.com/publish/formats/rss-0.91.dtd\">\n" .
          "\n" .
          "<rss version=\"0.91\">\n" .
          " <channel>\n" .
          "  <title>$title</title>\n" .
          "  <link>$link</link>\n" .
          "  <description>$desc</description>\n" .
          "  <language>$rss_lang</language>\n" .
          "  <webMaster>$rss_webmaster</webMaster>\n" .
          "  <managingEditor>$rss_editor</managingEditor>\n" .
          "  <pubDate>$pubdate</pubDate>\n" .
          "  <lastBuildDate>$builddate</lastBuildDate>\n" .
          "  <image>\n" .
          "   <title>$rss_img_title</title>\n" .
          "   <url>$rss_img_url</url>\n" .
          "   <width>$rss_img_width</width>\n" .
          "   <height>$rss_img_height</height>\n" .
          "   <link>$rss_img_link</link>\n" .
          "  </image>\n" .
          $items .
          " </channel>\n" .
          "</rss>\n");
}


# expands the first URL relative to the second.
#
sub expand_url($$) {
  my ($url, $base) = @_;

  $url =~ s/^\s+//gs;  # lose whitespace at front and back
  $url =~ s/\s+$//gs;

  if (! ($url =~ m/^[a-z]+:/)) {

    $base =~ s@(\#.*)$@@;       # strip anchors
    $base =~ s@(\?.*)$@@;       # strip arguments
    $base =~ s@/[^/]*$@/@;      # take off trailing file component

    my $tail = '';
    if ($url =~ s@(\#.*)$@@) { $tail = $1; }         # save anchors
    if ($url =~ s@(\?.*)$@@) { $tail = "$1$tail"; }  # save arguments

    my $base2 = $base;

    $base2 =~ s@^([a-z]+:/+[^/]+)/.*@$1@        # if url is an absolute path
      if ($url =~ m@^/@);

    my $ourl = $url;

    $url = $base2 . $url;
    $url =~ s@/\./@/@g;                         # expand "."
    1 while ($url =~ s@/[^/]+/\.\./@/@g);       # expand ".."

    $url .= $tail;                              # put anchors/args back

    print STDERR "$progname: relative URL: $ourl --> $url\n"
      if ($verbose > 2);

  } else {
    print STDERR "$progname: absolute URL: $url\n"
      if ($verbose > 2);
  }

  return $url;
}


# converts all relative URLs in SRC= or HREF= to absolute URLs,
# relative to the given base.
#
sub expand_urls($$) {
  my ($html, $base) = @_;

  $html =~ s/</\001</g;
  my @tags = split (/\001/, $html);

  foreach (@tags) {
    if (m/^(.*)\b(HREF|SRC)(\s*=\s*\")([^\"]+)(\".*)$/si) {
      my $head = "$1$2$3";
      my $url  = $4;
      my $tail = $5;
      $url = expand_url ($url, $base);
      $_ = "$head$url$tail";
    }
  }

  return join ('', @tags);
}


# Converts a blob of HTML to an RSS <item>
#
sub make_rss_item($$$) {
  my ($title, $link, $desc) = @_;

  $desc =~ s/^\s+//s;    # lose leading and trailing whitespace
  $desc =~ s/\s+$//s;

  $desc =~ s/[ \t\n]+/ /gs;   # convert all horizontal/vertical whitespace
                              #  to a single space (no newlines at all)

  # lose leading/trailing paragraph breaks
  $desc =~ s@^(<(P|BR)\b[^<>]*>\s*)+@@gsi;
  $desc =~ s@(\s*<(P|BR)\b[^<>]*>)+$@@gsi;

  $desc =~ s/ +$//gm;         # lose trailing whitespace

  $desc =~ s/&/&amp;/g;  # de-HTMLify
  $desc =~ s/</&lt;/g;
  $desc =~ s/>/&gt;/g;

  $desc =~ s/^/  /gm;
  $desc .= "\n" unless ($desc =~ m/\n$/s);

  my $item = ("<item>\n" .
              " <title>$title</title>\n" .
              " <link>$link</link>\n" .
              " <description>\n" .
              $desc .
              " </description>\n" .
              "</item>\n");
  return $item;
}


sub write_rss($$$$$$$) {
  my ($rss_title, $base_url, $rss_desc, $rss_nitems, $dir, $base, $file) = @_;

  my $bdate = strftime ("%a, %e %b %Y %H:%M:%S GMT", gmtime);

  my $body = make_rss ($rss_title, $base_url, $rss_desc, $bdate, $bdate,
                       $rss_nitems, $dir, $base);
  my $nbody = $body;
  my $obody = '';

  local *IN;
  if (open (IN, "<$file")) {
    while (<IN>) { $obody .= $_; }
    close IN;
  }

  # strip the dates out of both files, for comparison purposes
  #
  $nbody =~ s@<([a-z]+Date)>(.*?)</\1>@<$1>...</$1>@gsi;
  $obody =~ s@<([a-z]+Date)>(.*?)</\1>@<$1>...</$1>@gsi;

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


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

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


sub main() {
  my $dir = undef;
  my $file = undef;
  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (-d $_ && !defined($dir)) { $dir = $_; }
    elsif (!defined($file)) { $file = $_; }
    elsif (m/^-./) { usage; }
    else { usage; }
  }

  $dir = "." unless defined ($dir);
  $file = "$dir/latest.rss" unless defined($file);

  write_rss ($rss_title, $base_url, $rss_desc, $rss_nitems, $dir, $base_url,
             $file);
}

main();
exit 0;