バグっていたので改良版
バグあった
twitterにPOSTする時,401エラーでもう一回投げ直そうとする間に,requestがさらにリストに追加されて,無限にtwitterに投稿していました.投稿する条件を見直してみました.明日試験をやりなおして,問題なければいれかえ,と.
修正したスクリプト
#!/usr/local/bin/perl use strict; use warnings; no warnings qw(redefine); use FileHandle; # <- Needs for darwin os use URI; use Gungho::Inline; use Web::Scraper; use Encode qw(_utf8_off); use utf8; my $scraper = scraper { process 'td.bgltsub+td.bgwhite', 'descr[]' => 'text'; result 'descr'; }; Gungho::Inline->run( { throttle => { domain => { max_items => 10, interval => 300, domains => [ { match => '\.bosai\.go\.jp$' } ], } }, credentials => { basic => [ [ 'http://twitter.com:80', 'Twitter API', 'userid', 'passwd' ] ] }, components => [ 'Throttle::Domain', 'Authentication::Basic' ], quake => { status => 0, shake => undef }, }, { provider => \&provider, handler => \&handler, } ); sub provider { my ( $p, $c ) = @_; if ( $c->config->{quake}->{status} == 1 ) { $c->config->{quake}->{status} = 2; my $shake = $c->config->{quake}->{shake}; my $text = sprintf "%sにM%sの地震が%sで発生しました %sq=%s%%20%s", $$shake[1], $$shake[5], $$shake[0], 'http://maps.google.co.jp/maps?f=q&hl=ja&t=k&om=0&z=7&', $$shake[2], $$shake[3]; _utf8_off($text); my $uri = URI->new('http:'); $uri->query_form( status => $text ); $p->add_request( $c->prepare_request( Gungho::Request->new( POST => 'http://twitter.com/statuses/update.json', [ 'Content-Type', 'application/x-www-form-urlencoded' ], $uri->query, ) ) ); } else { my $url = 'http://www.hinet.bosai.go.jp'; $p->add_request( $c->prepare_request( Gungho::Request->new( GET => $url ) ) ); } 1; } sub handler { my ( $h, $c, $req, $res ) = @_; return 1 if ( !$res->is_success ); my $case = URI->new( $req->uri )->host; my $code = { 'www.hinet.bosai.go.jp' => sub { my $content_type = $res->headers->header('Content-Type'); my $enc = Encode::find_encoding($1) if ( $content_type =~ /charset=([A-Za-z0-9_\-]+)/io ); my $html = $enc->decode( $res->content ); my $old = $c->config->{quake}->{shake}; my $new = $scraper->scrape($html); if ( ( !$old ) or ( $$old[1] ne $$new[1] ) ) { $$new[2] =~ s/N//; $$new[3] =~ s/E//; $c->config->{quake}->{shake} = $new; $c->config->{quake}->{status} = 1; } }, 'twitter.com' => sub { $c->config->{quake}->{status} = 0; }, }->{$case}; $code->(); 1; }