changelog-to-rss

   1 #! /usr/bin/perl
   2 # Copyright (C) 2005  Alex Schroeder <alex@emacswiki.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the
  16 #    Free Software Foundation, Inc.
  17 #    59 Temple Place, Suite 330
  18 #    Boston, MA 02111-1307 USA
  19
  20 use CGI;
  21 use CGI::Carp qw(fatalsToBrowser);
  22 use LWP::UserAgent;
  23 use encoding 'utf8';
  24 use POSIX;
  25
  26 my $q = new CGI;
  27 my $url = $q->param('url');
  28 my $pattern = $q->param('pattern');
  29
  30 if (not $url) {
  31   print $q->header(),
  32     $q->start_html('ChangeLog to RSS'),
  33     $q->h1('ChangeLog to RSS'),
  34     $q->p('Translates ChangeLog output to RSS 2.0.'),
  35     $q->p(q{$Id: changelog-to-rss,v 1.17 2005/01/07 13:09:27 as Exp $}),
  36     $q->start_form(-method=>'GET'),
  37     $q->p('ChangeLog URL: ',
  38           $q->textfield('url', '', 70)),
  39     $q->p('Link pattern if available, use %s for the filename: ',
  40           $q->textfield('pattern', '', 70)),
  41     $q->p('Limit number of entries returned: ',
  42           $q->textfield('limit', '15', 5)),
  43     $q->p($q->submit()),
  44     $q->end_form(),
  45     $q->end_html();
  46   exit;
  47 }
  48
  49 print $q->header(-type=>'application/rss+xml; charset=UTF-8');
  50 my $rss = qq{<?xml version="1.0" encoding="UTF-8"?>
  51 <rss version="2.0">
  52 <channel>
  53 <title>ChangeLog</title>
  54 <description>RSS feed automatically extracted from a ChangeLog file.</description>
  55 <link>$url</link>
  56 };
  57
  58 my $ua = new LWP::UserAgent;
  59 my $response = $ua->get($url);
  60 die $response->status_line unless $response->is_success;
  61 my $data = $response->content;
  62
  63 my $limit = $q->param('limit') || 15;
  64 my ($date, $author, $file, $log, $count);
  65 foreach my $line (split(/\n/, $data)) {
  66   # print "----\n$line\n----\n";
  67   if ($line =~ m/^(\d\d\d\d-\d\d-\d\d)\s*(.*)/) {
  68     output($date, $author, $file, $log);
  69     $date = $1;
  70     $author = $2;
  71     $file = '';
  72     $log = '';
  73   } elsif ($line =~ m|^\t\* ([a-zA-Z0-9./-]+)(.*)|) {
  74     last if ++$count > $limit;
  75     output($date, $author, $file, $log);
  76     $file = $1;
  77     $log = $2;
  78   } else {
  79     $log .= "\n" . $line;
  80   }
  81 }
  82
  83 output($date, $author, $file, $log) if $file or $log;
  84 $rss .= q{
  85 </channel>
  86 </rss>
  87 };
  88
  89 print $rss;
  90
  91 sub output {
  92   my ($date, $author, $file, $log) = @_;
  93   return unless $file;
  94   $date = to_date($date);
  95   $author = quote_html($author);
  96   $log =~ s|^\t||mg; # strip leading tabs on every line
  97   $log =~ s|\)\n\(|, |g; # fix weird continuation groups
  98   # add linebreaks and highlighting for parentheses
  99   $log =~ s|\((.*?)\):|</span><span class="chunk"><br />(<strong>$1</strong>):|g;
 100   $log =~ s|^ *<br />||; # strip first linebreak, if there is one
 101   $log = quote_html($q->span({-class=>"chunk"}, $log));
 102   my $link = $pattern;
 103   $link =~ s/\%s/$file/g or $link .= $file;
 104   $rss .= "<item>\n";
 105   $rss .= "<author>$author</author>\n" if $author;
 106   $rss .= "<pubDate>$date</pubDate>\n" if $date;
 107   $rss .= "<title>$file</title>\n" if $file;
 108   $rss .= "<link>$link</link>\n" if $link;
 109   $rss .= "<description>$log</description>\n" if $log;
 110   $rss .= "</item>\n\n";
 111 }
 112
 113 sub to_date {
 114   $_ = shift;
 115   my ($year, $month, $day) = split(/-/);
 116   # Wed, 02 Oct 2002 00:00:00 GMT
 117   return strftime("%a, %d %b %Y 00:00:00 GMT",
 118                   0, 0, 0, $day, $month - 1, $year - 1900);
 119 }
 120
 121 sub quote_html {
 122   $_ = shift;
 123   s/&/&amp;/g;
 124   s/</&lt;/g;
 125   s/>/&gt;/g;
 126   s/&amp;([#a-zA-Z0-9]+);/&$1;/g;  # Allow character references
 127   return $_;
 128 }