view release on metacpan or  search on metacpan

lib/Apache/RSS.pm  view on Meta::CPAN

package Apache::RSS;
# $Id: RSS.pm,v 1.6 2002/05/30 14:08:03 ikechin Exp $

use strict;
use Apache::Constants qw(:common &OPT_INDEXES &DECLINE_CMD);
use Time::Piece;
use XML::RSS;
use DirHandle;
use URI;
use DynaLoader ();
use Apache::ModuleConfig;
use Apache::Util qw(escape_html);
use vars qw($VERSION);

$VERSION = '0.05';

if($ENV{MOD_PERL}) {
    no strict;
    @ISA = qw(DynaLoader);
    __PACKAGE__->bootstrap($VERSION);
}

sub handler($$){
    my($class, $r) = @_;
    my $cfg = Apache::ModuleConfig->get($r) || {};
    # check permission
    unless (-d $r->filename) {
	return DECLINED;
    }
    my %args = $r->args;
    unless ($args{index} && $args{index} eq 'rss') {
	return DECLINED;
    }
    if (!($r->allow_options & OPT_INDEXES)) {
	$r->log_reason("Options Indexes is off in this directory", $r->filename);
	return FORBIDDEN;
    }

    my $base   = base_uri($r);
    my @items  = open_dir($r, $cfg, $base);
    my $sorter = build_sorter(\%args);
    @items = sort { $sorter->($a, $b) } @items;

    my $rss = create_rss($r, $cfg, \@items, $base);
    # send content
    $r->send_http_header('text/xml');
    $r->print($rss->as_string);
    return OK;
}

sub base_uri {
    my $r = shift;
    my $base = URI->new($r->uri, "http");
    $base->host($r->hostname);
    $base->port($r->server->port) if $r->server->port != 80;
    $base->scheme('http');
    return $base;
}

sub open_dir {
    my($r, $cfg, $base) = @_;

    my $dir = $r->filename;
    my $d = DirHandle->new($dir);
    unless ($d) {
	$r->log_reason("Can't open directory", $dir);
	return FORBIDDEN;
    }

    my $regexp = $cfg->{'RSSEnableRegexp'};
    my @items = ();
    while (my $file = $d->read) {
	next if $file =~ /^\./;
	next if $regexp && $file !~ m/$regexp/;
	my $subr = $r->lookup_uri($file);
	next unless -f $subr->filename;
	push @items, Apache::RSS::Item->new({
	    content_type => $subr->content_type,
	    title => $cfg->{'RSSScanHTMLTitle'} ? (find_title($subr, $cfg) || $file) : $file,
	    name => $file,
	    link => URI->new_abs($file, $base),
	    filename => $subr->filename,
	    mtime => (stat $subr->finfo)[9]
	});
    }
    $d->close;
    return @items;
}

sub create_rss {
    my($r, $cfg, $items, $base) = @_;
    my $req_time = Time::Piece->new($r->request_time);
    my $channel_title = 
	$cfg->{'RSSChannelTitle'} || sprintf("Index Of %s", $r->uri);
    my $channel_description = 
	$cfg->{'RSSChannelDescription'} || sprintf("Index Of %s", $r->uri);
    my $copyright =
	$cfg->{'RSSCopyRight'} || sprintf("Copyright %d %s", $req_time->year, $r->hostname);
    my $language = $cfg->{'RSSLanguage'} || "en-us";
    my $encoding = $cfg->{'RSSEncoding'} || "UTF-8";

    my $rss = XML::RSS->new(version => '0.91', encoding => $encoding);
    $rss->channel(
	title => escape_html($channel_title),
	link => $base,
	description => escape_html($channel_description),
	webMaster => $r->server->server_admin,
	pubDate => $req_time->datetime,
	lastBuildDate => $req_time->datetime,
	copyright => escape_html($copyright),
	language => $language,
    );
    foreach my $item (@$items) {
	$rss->add_item(
	    link => $item->link,
	    title => escape_html($item->title),
	);
    }
    return $rss;
}

sub find_title {
    my($subr, $cfg) = @_;
    my $encoder = $cfg->{'RSSEncodeHandler'};
    if ($subr->content_type =~ m#^text/html#) {
	local $/ = undef;
	my $f = IO::File->new($subr->filename, "r") or return undef;
	my $html = <$f>;
	$html =~ m#<title>([^>]+)</title>#i;
	return undef unless $1;
	if ($encoder) {
	    my $enc = $encoder->new;
	    return $enc->encode($1);
	}
	else {
	    return $1;
	}
    }
    return undef;
}

my %SortBy = (
    'N' => 'title' ,
    'M' => 'mtime',
);

sub build_sorter {
    my $args = shift;

    # N=A by default
    my $sortby = (grep exists $args->{$_}, keys %SortBy)[0] || 'N';
    my $order  = $args->{$sortby} || 'A';
    my @target = $order eq 'A' ? qw($_[0] $_[1]) : qw($_[1] $_[0]);
    my $cmp    = $sortby eq 'N' ? 'cmp' : '<=>';

    return eval sprintf "sub { %s->%s %s %s->%s }",
	$target[0], $SortBy{$sortby}, $cmp, $target[1], $SortBy{$sortby};
}

##----------------------------------------------------------------
## Directives
##----------------------------------------------------------------
sub RSSEnableRegexp($$$){
    my($cfg, $params, $arg) = @_;
    $cfg->{RSSEnableRegexp} = eval "qr/$arg/";
    die $@ if $@;
}

sub RSSChannelTitle($$$) {
    my($cfg, $params, $arg) = @_;
    $cfg->{RSSChannelTitle} = $arg;
}

sub RSSChannelDescription($$$) {
    my($cfg, $params, $arg) = @_;
    $cfg->{RSSChannelDescription} = $arg;