#!/usr/bin/perl -w
#######################################################################
### $Id: robot_pl.txt,v 1.3 2003/09/24 07:11:49 mate Exp $
###

use strict;
use URI;
use LWP::UserAgent;
use HTTP::Date;
use Jcode;
my $VERSION = '0.01';
my ($URLDAT, $DELIMITER,
    $UA, $UA_PROXY, $UA_PROXY_BYPASS, $UA_TIMEOUT, $UA_NAME,
    $SENDMAIL, $SENDMAIL_PATH, $MAIL_TO, $MAIL_SUBJECT, $MAIL_FROM,
    $DEBUG);

#######################################################################
# 設定ここから

# 巡回 URL リストファイル
$URLDAT = "./robot.dat";

# URL ファイルの区切文字
$DELIMITER = ';';

# メール送信(0=しない,1=する)
# 0 の場合は標準出力に結果を表示します。
# 追加記事がない場合は送信しません。
$SENDMAIL = 1;

# 送信コマンド
$SENDMAIL_PATH = '/usr/sbin/sendmail';

# メール件名
$MAIL_SUBJECT = 'ページが更新されました! ($total)';

# メール送信先
$MAIL_TO = '';

# メール FROM
$MAIL_FROM = "ROBOT <$MAIL_TO>";

# $UA_PROXY = 'http://my.proxy.server.domain.name:port/';
# $UA_PROXY_BYPASS = ['localhost','127.0.0.1'];
# $UA_TIMEOUT = 10;
# $UA_NAME = "robot/$VERSION";
$DEBUG = 0;

# 設定ここまで
#######################################################################
$|=1;

$UA = LWP::UserAgent->new;
$UA->agent(defined($UA_NAME) ? $UA_NAME : "robot/$VERSION");
$UA->timeout(defined($UA_TIMEOUT) ? $UA_TIMEOUT : 10);
$UA->proxy(['http'], $UA_PROXY) if (defined $UA_PROXY);
$UA->no_proxy($UA_PROXY_BYPASS) if (defined $UA_PROXY_BYPASS);
$UA->env_proxy unless (defined($UA_PROXY) || defined($UA_PROXY_BYPASS));

my (%template, %loop);
my $total = 0;
my $mail_loop = "";
read_template(\%template);

open(F, $URLDAT) or die "Can not open: $URLDAT";
open(W, ">$URLDAT.wrk") or die "Can not open: $URLDAT.wrk";
while (<F>) {
    if (/^\#/) {
        print W $_;
        next;
    }
    chomp;
    my ($title, $old_time, $url) = split($DELIMITER, $_, 3);
    if ($url !~ /^http/) {
        warn("WARNING: BAD URL($url), SKIP!\n");
        next;
    }
    undef %loop;
    $loop{title} = $title;
    my $new_time = get_time($old_time, URI->new($url), \%loop);
    if (defined($new_time)) {
        $mail_loop .= parse_template($template{URL}, { %loop, url => $url });
        $total++;
    } else {
        $new_time = $old_time;
    }
    print W "$loop{title}$DELIMITER$new_time$DELIMITER$url\n";
}
close(F);
close(W);

unlink($URLDAT) or die "Can not unlink: $URLDAT";
rename("$URLDAT.wrk", $URLDAT) or die "Can not rename: $URLDAT.wrk";

exit if ($total < 1);

if ($SENDMAIL) {
    $MAIL_SUBJECT = parse_template($MAIL_SUBJECT, { total => $total });
    my %header = (version => $VERSION,
               to => Jcode->new($MAIL_TO)->mime_encode,
               subject => Jcode->new($MAIL_SUBJECT)->mime_encode,
               from => Jcode->new($MAIL_FROM)->mime_encode);
    my %footer = ();
    my $mail_head = parse_template($template{HEADER}, \%header);
    my $mail_foot = parse_template($template{FOOTER}, \%footer);
    my $mail_body = $mail_loop.$mail_foot;
    sendmail($MAIL_TO, \$mail_head, \$mail_body);
} else {
    print $mail_loop;
}
exit;
# End of Main
#######################################################################

sub get_time {

    my ($time, $uri, $datref) = @_;

    my $req = HTTP::Request->new(GET => $uri);
    $req->header('If-Modified-Since' => HTTP::Date::time2str($time)) if $time;
    my $res = $UA->request($req);
    $datref->{last_modified} = $res->header('last-modified') || "";
    warn("$uri (".$res->message.")\n") if $DEBUG;

    unless ($res->is_success) {
        $datref->{error} = $res->message;
        return 0 if $res->code == 403; # Forbidden
        return 0 if $res->code == 404; # Not Found
        return undef;
    }

    unless ($datref->{title}) {
        my $html = $res->content;
        ($datref->{title}) = $html =~ m#<title>(.+)</title>#is;
        $datref->{title} =~ s/[\t\r\n]//g if $datref->{title} =~ /[\t\r\n]/;
        $datref->{title} = Jcode->new($datref->{title})->h2z->sjis;
        $datref->{title} ||= "*";
    }

    return time;

}

sub read_template {

    my ($tmplref) = @_;
    my ($group);

    while (<DATA>) {
        last if (/__END__/);
        if (/^#+\s+(\w+)/) {
            $group = $1;
            next;
        }
        $tmplref->{$group} .= $_;
    }

}

sub parse_template {

    my ($tmpl, $datref) = @_;

    if (ref($datref) eq 'HASH') {
        if ($tmpl =~ /\$\w+/) {
            $tmpl =~ s/\$(\w+)/$$datref{$1} ? $$datref{$1} : ""/eg;
        }
    }
    elsif (ref($datref) eq 'ARRAY') {
        my $t = "";
        foreach (@$datref) {
            $t .= parse_template($tmpl, $_);
        }
        $tmpl = $t;
    }
    $tmpl =~ s#\n[\s\t]+\n#\n\n#g if ($tmpl =~ /\n[\s\t]+\n/);
    $tmpl =~ s#\n\n\n+#\n\n#g if ($tmpl =~ /\n\n\n/);

    return $tmpl;

}

sub sendmail {

    my ($to, $headref, $bodyref) = @_;

    unless ($to) { warn("WARNING: mail to-address not found\n"); return; }
    unless ($$headref) { warn("WARNING: mail header not found\n"); return; }
    unless ($$bodyref) { warn("WARNING: mail body not found\n"); return; }
    unless (-e $SENDMAIL_PATH) { warn("WARNING: $SENDMAIL_PATH not found\n"); return; }

    open(M, "|-") || exec $SENDMAIL_PATH, $to;
    print M Jcode->new($$headref)->h2z->jis;
    print M Jcode->new($$bodyref)->h2z->jis;
    close(M);

    return;
}

__DATA__
## HEADER
To: $to
From: $from
Subject: $subject
X-Mailer: robot/$version

## URL
<$title>$error
$url

## FOOTER
-------------------------------------------------------------------------
__END__
### Local Variables:
### mode: perl
### End:

=head1 NAME

robot.pl - サイト更新通知スクリプト

=head1 SYNOPSIS

robot.dat を作成します。# から始まる行はコメントです。
通常は、タイトル名と URL を ; で区切って設定して下さい。
タイトル名に日本語を使用する場合は、SJIS で記入して下さい。

タイトル名を指定しない場合は、<title>〜</title> から取得を試みます。
URL は、ファイル名までのパスを指定して下さい。

サンプルは次のようになります。

  #
  # URLs for robot.pl
  #
  # <タイトル名>;<最終チェック時刻>;<ページURL>
  #
  HogeHoge;;http://www.domain.co.jp/index.html
  ;;http://www.domain.co.jp/page.html

最終チェック時刻は、robot.pl を実行した時に設定されます。
robot.pl の設定を行って実行して下さい。

 ./robot.pl

=head1 DESCRIPTION

 例) cron で実行する場合

 0 * * * * /path/to/robot.pl

=head1 AUTHOR

Yutaka Kojima E<lt>yutaka@asmate.netE<gt>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 HISTORY

 0.01 Mon Sep 22 19:23:07 JST 2003
 * リリース

=cut