少し手馴れたircbot - file-glob こと k.daibaの日記

バージョンアップ

昨日の日記に

これHTML::TagParserの中でLWPか何かでダウンロードしてTITLEをとっているんですよね。とすると、URLのサイトが重かったりするとブロックしてしまうとおもいます。POE::Component::Client::HTTP などでドキュメントを取得してからパーサにまわすほうがいいかと。

と，宮川さんからコメントを頂いたので作ってみました．POE::Componentを複数個使ったスクリプトを組むのは覚えてる限り初めてだったので，ちょっと時間がかかりました．

title.pl

#!/usr/local/bin/perl

use POE qw(Component::IRC Component::Client::HTTP);
use HTTP::Request::Common qw(GET);
use HTML::TagParser;
use Encode qw(from_to);
use strict;

my ( $nick, $ircname, $server, $channel, $port );
my ($url);

$nick    = 'poe0';
$ircname = 'titlebot';
$server  = 'irc.hoge.co.jp';
$channel = '#test';
$port    = 6667;

$url = q{s?https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+};

POE::Component::IRC->spawn(
    Alias   => 'irc',
    nick    => $nick,
    server  => $server,
    port    => $port,
    ircname => $ircname,
);

POE::Component::Client::HTTP->spawn(
    Alias           => 'ua',
    Timeout         => 30,
    FollowRedirects => 2,
);

POE::Session->create(
    package_states => [

        #        'IRC' => [qw(_default _start irc_001 irc_public)],
        'IRC' => [qw( _start irc_001 irc_public)],
        'UA'  => [qw(got_response)],
    ],
);

POE::Kernel->run();
exit 0;

sub IRC::_start {
    my $kernel = $_[KERNEL];
    $kernel->post( irc => register => 'all' );
    $kernel->post( irc => connect => {} );
    undef;
}

sub IRC::irc_001 {
    my $kernel = $_[KERNEL];
    $kernel->post( irc => join => $channel );
    undef;
}

sub IRC::irc_public {
    my ( $kernel, $msg ) = @_[ KERNEL, ARG2 ];
    my ($http);
    if ( ($http) = $msg =~ m/^title ($url)/ ) {
        $kernel->post( ua => request => got_response => GET $http);
    }
    undef;
}

sub UA::got_response {
    my ( $kernel, $packet ) = @_[ KERNEL, ARG1 ];
    my ( $data, $title );
    $data = $packet->[0]->content;
    eval {
        my $html = HTML::TagParser->new($data);
        my $elem = $html->getElementsByTagName('title');
        $title = $elem->innerText();
        from_to( $title, 'utf-8', 'iso-2022-jp' );
    };
    $title = 'Error to get Title.' if ($@);
    $kernel->post( irc => privmsg => $channel => $title );
    undef;
}

sub IRC::_default {
    my ( $event, $args ) = @_[ ARG0 .. $#_ ];
    my @output = ("$event: ");
    for my $arg (@$args) {
        if ( ref($arg) eq 'ARRAY' ) {
            push( @output, "[" . join( " ,", @$arg ) . "]" );
        }
        else {
            push( @output, "'$arg'" );
        }
    }
    print join ' ', @output, "\n";
    return 0;
}

ちょっとした解説

POCO::Client::HTTPとPOCO::IRCを組み合わせる方法を考えていて，注目したのがPOCP::IRC の解説でした．読んで見ると，

  POE::Session->create(
        package_states => [
                'main' => [ qw(_default _start irc_001 irc_public) ],
        ],
        heap => { irc => $irc },
  );

package_statesという今まで使ったことがないキーワードがあってこれが使えそうです．ちなみにこのサンプル，コールバック関数が

  sub _start {
    my ($kernel,$heap) = @_[KERNEL,HEAP];
    ...
    undef;
  }

undefで終わっていたりと，なんだかカッコよさげです．ただ，$ircをheap領域で持ちまわるのはイマイチな感じだったので，Aliasでセッションを識別するようにしてみました．つまり，

sub IRC::_start {
    my $kernel = $_[KERNEL];
    $kernel->post( irc => register => 'all' );
    $kernel->post( irc => connect => {} );
    undef;
}

こういうことです．ここで，postの第一引数になっているircが識別子です．POE::Sessionの解説によると，

In package states, it contains the name of the package whose method is being invoked. Again, it's useful for invoking plain package methods once an event has arrived.

ということなので，コールバック名はIRC::_startとなります．ちなみに，package名をmainと指定した場合のコールバック名は，_startです．

終わりに

GETがエラーになった際のエラー処理の部分をまぢめに考えないといけないような気はするものの，とりあえず動いたので，こんな感じでいいのかな．そういえば，

sub IRC::_default {
    my ( $event, $args ) = @_[ ARG0 .. $#_ ];

というデバック用のコールバックもPOCP::IRC の解説から頂いてきたんですが，この書き方，面白いですね．目からウロコでした．