Trackback Ping 一覧を RSS 出力する

#!/usr/local/bin/perl -w
# tb_rss - implements __mode=rss

use strict;
use CGI;
use DBI;
use HTML::Entities;
use Time::Piece;
use XML::RSS;

our $dbdir = "/tmp";
our @cols  = qw(url title blog_name excerpt timestamp);
our $tb_prefix = "Blog Developer's Trackback";
our $tb_link   = "http://example.com/tb";

my $query = CGI->new();
   $query->charset('utf-8');

my $tb_id = munge_tb_id($query) or do {
    send_response(1 => "Invalid Trackback ID");
    exit;
};

my $mode  = $query->param('__mode');
if ($mode && $mode eq 'rss') {
    show_rss($query, $tb_id);
} else {
    receive_ping($query, $tb_id);
}

sub receive_ping {
    my($query, $tb_id) = @_;
    my $vars = $query->Vars();

    if (!$vars->{url}) {
        send_response(1 => "No url parameter (required)");
        return;
    }

    fix_encoding($vars) if $vars->{charset};

    # Default values
    $vars->{title}     ||= $vars->{url};
    $vars->{blog_name} ||= do {
        require URI;
        URI->new($vars->{url})->host;
    };
    $vars->{excerpt} ||= "No excerpt.";
    $vars->{timestamp} = Time::Piece->new->datetime;

    eval {
        store_ping($tb_id, $vars);
        send_response(0 => "Thanks for your Ping to $tb_id");
    };

    if ($@) {
        send_response(1 => "Error while storing ping: $@");
    }
}

sub fix_encoding {
    my $vars = shift;
    require Encode;
    Encode::from_to($vars->{$_},
                    $vars->{charset} => "utf-8") for @cols;
}

sub store_ping {
    my($tb_id, $vars) = @_;
    my $dbh = connect_db($tb_id);

    # Generate SQL statements
    my $sql = sprintf "INSERT INTO tb (%s) VALUES (%s)",
        join(",", @cols), join(",", ('?') x @cols);
    my $sth = $dbh->prepare($sql);
    $sth->execute(@{$vars}{@cols});
    $sth->finish();

    $dbh->disconnect();
}

sub connect_db {
    my $tb_id = shift;
    my $is_existent = -e "$dbdir/$tb_id.db";
    my @dsn = ("dbi:SQLite:dbname=$dbdir/$tb_id.db", "", "");
    my $dbh = DBI->connect(@dsn, { RaiseError => 1,
                                   AutoCommit => 1, });

    # Create table "tb" if it's first time
    init_table($dbh) unless $is_existent;
    return $dbh;
}

sub init_table {
    my $dbh = shift;
    $dbh->do(<<SQL);
CREATE TABLE tb (
  url    VARCHAR(255) NOT NULL,
  title  VARCHAR(255) NOT NULL,
  blog_name VARCHAR(255) NOT NULL,
  excerpt TEXT,
  timestamp DATETIME
)
SQL
    ;
}

sub show_rss {
    my($query, $tb_id) = @_;
    my $dbh = connect_db($tb_id);
    my $sql = sprintf "SELECT %s FROM tb ORDER BY timestamp DESC",
        join(",", @cols);
    my $sth = $dbh->prepare($sql);
    $sth->execute();

    my $rss = XML::RSS->new(version => 0.91);
    $rss->channel(
        title => "$tb_prefix: $tb_id",
        link  => "$tb_link/$tb_id",
        description => "Trackback Discussion on $tb_id",
    );

    while (my $data = $sth->fetchrow_hashref) {
        $rss->add_item(
            title => $data->{title},
            link  => $data->{url},
        );
    }
    $sth->finish();
    send_rss($query, $rss);
}

sub munge_tb_id {
    my $query = shift;
    my $path_info = $query->path_info();
    $path_info && $path_info =~ m!(\w+)! && return $1;
    return;
}

sub send_response {
    my($error, $message, $no_escape) = @_;
    my $msg = $no_escape ? $message : encode_entities($message);
    print $query->header('text/xml'), <<XML;
<?xml encoding="utf-8"?>
<response>
  <error>$error</error>
  <message>$msg</message>
</response>
XML
    ;
}

sub send_rss {
    my($query, $rss) = @_;
    my $rss_node = hack_rss_node($rss->as_string);
    print $query->header('text/xml'), <<XML;
<?xml encoding="utf-8"?>
<response>
  <error>0</error>
  $rss_node
</response>
XML
    ;
}

sub hack_rss_node {
    my $rss = shift;
    $rss =~ s@<\?xml .*?>\n*@@s;
    $rss =~ s@<!DOCTYPE rss .*?>\n*@@s;
    return $rss;
}