フレッツ故障情報の抽出
Web::Scrapperとautoboxを使う
先日，ブランチオフィスへの通信が急にダウンしました．ルータが壊れたのか，とか色々疑って調べたあげくBフレッツが故障してるとの情報を発見，結局それが原因だったのでした．その時に思ったのが東西NTTのフレッツ故障情報がえらく探しにくいということ．NTT東日本：フレッツ｜スクウェア｜工事・故障情報から都道府県とサービスを選択して，ちまちま追いかけていく必要がありました．そこで，毎度そんなことをするのはメンドクサイので，各都道府県の故障情報を抽出してそれをtwitterに投げるbotを作ってみました．今回スクリプトはWeb::Scrapperとautoboxを使っていることが特徴です．POEをベースにしようかとも思ったのですが，処理が複雑なので今回はあきらめて，5分毎にcronで起動してhttp://twitter.com/fletswatchに投げています．
フレッツ故障情報
今回作ったスクリプトは，NTT東日本とNTT西日本が公開しているフレッツ故障情報を定期的にチェックして，更新情報があったらそれをtwitterに投げています．と，簡単に言っていますがこのスクリプト，東西用で全然別の動きをしています．というのは，東日本と西日本とで情報提示フォーマットがまるっきり違うからです．東日本の場合は上記ページを解析すれば必要な情報を抽出することができますが，西日本の場合には，このページに記載してあるリンクを辿って，辿った先のページから必要な情報を抽出する必要がありました．
NTT東日本用
スクリプトは，NTT東日本のフレッツ故障情報を以下のページから拾っています．
NTTEast: - http://flets.com/const/nw_t_niigata.html - http://flets.com/const/nw_t_tokyo.html - http://flets.com/const/nw_t_kanagawa.html - http://flets.com/const/nw_t_chiba.html - http://flets.com/const/nw_t_iwate.html - http://flets.com/const/nw_t_ibaraki.html - http://flets.com/const/nw_t_miyagi.html - http://flets.com/const/nw_t_yamagata.html - http://flets.com/const/nw_t_tochigi.html - http://flets.com/const/nw_t_fukushima.html - http://flets.com/const/nw_t_gunma.html - http://flets.com/const/nw_t_aomori.html - http://flets.com/const/nw_t_saitama.html - http://flets.com/const/nw_t_yamanashi.html - http://flets.com/const/nw_t_hokkaido.html - http://flets.com/const/nw_t_akita.html - http://flets.com/const/nw_t_nagano.html
スクリプトは，情報を抽出する部分と，それを加工する部分からできています．まず抽出する部分はこんな感じ．
$scraper = scraper { process 'div.margin+p', 'area' => 'TEXT'; process 'table[summary="工事情報"] tr', 'down[]' => scraper { process 'td[width="146"]', 'type' => 'TEXT'; process 'a', 'url' => '@href'; process 'td[width="205"]', 'time' => 'TEXT'; }; result 'area', 'down'; }; $downs = $scraper->scrape( URI->new($uri) );
htmlから情報を抽出するためにWeb::Scrapperを使っています．例えば，都道府県名を抽出するためには，東京都の故障情報ページの「東京都の故障情報です」の部分を使っていたり，フレッツ種別や故障の発生復旧時刻を抽出する為にテーブルエントリの幅が持つ値を利用しています．次に加工する部分です．
$data->area( $area->m(qr{(.*)の故障})->[0] ); $data->type( $$down{type}->m(qr{Bフレッツ})->[0] + $$down{type}->m(qr{フレッツ・?ISDN})->[0] * 4 + $$down{type}->m(qr{フレッツ・?ADSL})->[0] * 8 ); $data->url( URI->new_abs( $$down{url}, $uri ) ); ( $begin, $end ) = split( /〜/, $$down{time} ); $data->begin( sprintf "%d/%d %02d:%02d", @{ $begin->m(qr{(\d+)月(\d+)日\D+(\d+):(\d+)}) } ); $data->end( sprintf "%d/%d %02d:%02d", @{ $end->m(qr{(\d+)月(\d+)日\D+(\d+):(\d+)}) } ); $data->end('') if ( $data->end->m(qr{0/0})->[0]);
要は正規表現を使っているのですが，このスクリプトでは文字列をfirst-class objectとして扱っています．と，言っても私はfirst-classとは何ぞやというのをよくわかっていません．perlでのfirst-class objectの取り扱いに関してはautobox - use builtin datatypes as first-class objects - metacpan.orgとautobox::Core - Perl built-in functions exposed as methods in primitive types - metacpan.orgをご覧ください．今回のスクリプトでは，m,s,sgを自前で定義しました．
package SCALAR; sub m($$) { [ $_[0] =~ m{$_[1]} ] } sub s($$$) { $_[0] =~ s{$_[1]}{$_[2]} } sub sg($$$) { $_[0] =~ s{$_[1]}{$_[2]}g }
m,sはautobox::Coreに元々あるのですが，繰り返し置換するsgが欲しかったので，autobox::Coreを使わずに作成しました．
NTT西日本用
スクリプトは，NTT西日本のフレッツ故障情報を以下のページから拾っています．
NTTWest: - http://www.ip-nw.com/nwc/osaka/trouble.html - http://www.ip-nw.com/nwc/hyogo/trouble.html - http://www.ip-nw.com/nwc/kagoshima/trouble.html - http://www.ip-nw.com/nwc/kagawa/trouble.html - http://www.ip-nw.com/nwc/kyoto/trouble.html - http://www.ip-nw.com/nwc/okinawa/trouble.html - http://www.ip-nw.com/nwc/kumamoto/trouble.html - http://www.ip-nw.com/nwc/mie/trouble.html - http://www.ip-nw.com/nwc/shizuoka/trouble.html - http://www.ip-nw.com/nwc/aichi/trouble.html - http://www.ip-nw.com/nwc/okayama/trouble.html - http://www.ip-nw.com/nwc/tokushima/trouble.html - http://www.ip-nw.com/nwc/ishikawa/trouble.html - http://www.ip-nw.com/nwc/oita/trouble.html - http://www.ip-nw.com/nwc/nara/trouble.html - http://www.ip-nw.com/nwc/ehime/trouble.html - http://www.ip-nw.com/nwc/shimane/trouble.html - http://www.ip-nw.com/nwc/kochi/trouble.html - http://www.ip-nw.com/nwc/fukuoka/trouble.html - http://www.ip-nw.com/nwc/fukui/trouble.html - http://www.ip-nw.com/nwc/wakayama/trouble.html - http://www.ip-nw.com/nwc/yamaguchi/trouble.html - http://www.ip-nw.com/nwc/miyazaki/trouble.html - http://www.ip-nw.com/nwc/gifu/trouble.html - http://www.ip-nw.com/nwc/tottori/trouble.html - http://www.ip-nw.com/nwc/toyama/trouble.html - http://www.ip-nw.com/nwc/shiga/trouble.html - http://www.ip-nw.com/nwc/hiroshima/trouble.html - http://www.ip-nw.com/nwc/saga/trouble.html - http://www.ip-nw.com/nwc/nagasaki/trouble.html
さて，このスクリプトも情報を抽出する部分と，抽出した情報を加工する部分からできています．抽出は2段階に行っていて，最初の抽出は
my $scraper = scraper { process 'td[width=500] a', 'url[]' => '@href'; result 'url'; }; my $urls = $scraper->scrape( URI->new($uri) );
としていて，詳細な情報が記載されているページのurlを抜き出しています．その，抜き出した詳細情報のページから，
my $text = scraper { process 'b', 'area' => 'TEXT'; process 'pre', 'text' => 'TEXT'; result 'area', 'text'; }; my $data = new FletsFailure::Data; $down = $text->scrape($uri);
"故障情報（大阪府）"という文字列と，「故障発生のおしらせ」という，おそらくメールで流しているテキストを文字列を抽出しています．次にスクリプトは，情報を加工します．
$$down{text} =~ tr/０-９：（）Ａ-Ｚａ-ｚ /0-9:()A-Za-z /; $desc = $$down{text}->m(qr{影 響:([^。]+)}s)->[0]; $desc->s( qr{原 因.+$}, "" ); $desc->sg( qr{\s+}, "" ); $data->url($uri); $data->area( $$down{area}->m(qr{（(.+)）})->[0] ); $data->begin( sprintf "%d/%d %02d:%02d", @{ $$down{text}->m(qr{発生日時:(.+)\n}m)->[0] ->m(qr{(\d+)月\s*(\d+)日\D+\s*(\d+):(\d+)}) } ); eval { $data->end( sprintf "%d/%d %02d:%02d", @{ $$down{text}->m(qr{回復日時:(.+)\n}m)->[0] ->m(qr{(\d+)月\s*(\d+)日\D+\s*(\d+):(\d+)}) } ); }; $data->end('') if $@; $data->type( $desc->m(qr{Bフレッツ・?サービス})->[0] + $desc->m(qr{フレッツ・?シリーズサービス})->[0] * 2 + $desc->m(qr{フレッツ・?ISDNサービス})->[0] * 4 + $desc->m(qr{フレッツ・?ADSLサービス})->[0] * 8 );
m,s,sgは先に説明した通り，文字列を"first-class object"として扱う際のメソッドです．trも挑戦したのですが，動きませんでした．evalで囲っていたりとかちょっと美しくないですが，やっつけな作りとしてはそれなりに動いています．
まとめ
今回のスクリプトは，東西NTTが公開しているフレッツ故障情報をtwitterに投稿しています．それにしても，東西NTT，NGNだか次世代情報網だか言ってるわりには，情報発信ちゃちいなと思います．APIでも定義して，希望するサービスとか都道府県の情報を取得できるようにして欲しいなと．それから今回うまくいかなかったautoboxを使ったtr，以下のような定義になると思ってます．
perl -Mautobox -le ' { package SCALAR; sub tr($$$){$_ = $_[0]; eval "tr/$_[1]/$_[2]/"; die $@ if $@;$_[0] = $_} } $a = "aaabbc"; print $a->tr("a","d")' dddbbc
ワンライナーを無理矢理改行して書いてるのでわかりづらいと思いますが，これでいちよう'dddbbc'と出力します．trはコンパイル時に文字列を確定するので，evalを使って，実行時に文字列値が確定するようにしています．このスクリプトは英数字ではうまくうごきますが，utf-8を使った日本語だとちゃんと動きませんでした．もう少し捻ってみる必要があるようです．
ソースコード
#!/usr/local/bin/perl use autobox; { package SCALAR; sub m($$) { [ $_[0] =~ m{$_[1]} ] } sub s($$$) { $_[0] =~ s{$_[1]}{$_[2]} } sub sg($$$) { $_[0] =~ s{$_[1]}{$_[2]}g } 1; } { package FletsFailure::Data; use base qw(Class::Data::Inheritable); use base qw(Class::Accessor); use utf8; use Digest::MD5 qw(md5_base64); use Encode qw(_utf8_off); FletsFailure::Data->mk_accessors(qw(area type url begin end)); FletsFailure::Data->mk_classdata('list'); my @list = (); FletsFailure::Data->list( \@list ); sub pushme { my $self = shift; my $listref = $self->list; push @$listref, $self; } sub msg { my $self = shift; my $str = $self->area . 'で' . ( { 1 => "Bフレッツ", 2 => "フレッツシリーズ", 4 => "フレッツISDN", 8 => "フレッツADSL" }->{ $self->type } || "未定義" ) . 'に故障．発生' . $self->begin; $str .= ' 回復' . $self->end if ( $self->end ); $str .= ' ' . $self->url; return $str; } sub digest { my $self = shift; my $str = $self->msg; _utf8_off($str); return md5_base64($str); } 1; } { package FletsFailure::NTTEast; use Web::Scraper; use URI; use utf8; sub extract { my $class = shift; my $uri = shift; my ( $scrape, $downs ); $scraper = scraper { process 'div.margin+p', 'area' => 'TEXT'; process 'table[summary="工事情報"] tr', 'down[]' => scraper { process 'td[width="146"]', 'type' => 'TEXT'; process 'a', 'url' => '@href'; process 'td[width="205"]', 'time' => 'TEXT'; }; result 'area', 'down'; }; $downs = $scraper->scrape( URI->new($uri) ); map { my $down = $_; $class->setup( $uri, $$downs{area}, $down ); } @{ $$downs{down} }; } sub setup { my $class = shift; my ( $uri, $area, $down ) = @_; my ( $begin, $end, $dateandtime ); return if ( scalar( keys(%$down) ) != 3 ); my $data = new FletsFailure::Data; $data->area( $area->m(qr{(.*)の故障})->[0] ); $data->type( $$down{type}->m(qr{Bフレッツ})->[0] + $$down{type}->m(qr{フレッツ・?ISDN})->[0] * 4 + $$down{type}->m(qr{フレッツ・?ADSL})->[0] * 8 ); $data->url( URI->new_abs( $$down{url}, $uri ) ); ( $begin, $end ) = split( /〜/, $$down{time} ); $data->begin( sprintf "%d/%d %02d:%02d", @{ $begin->m(qr{(\d+)月(\d+)日\D+(\d+):(\d+)}) } ); $data->end( sprintf "%d/%d %02d:%02d", @{ $end->m(qr{(\d+)月(\d+)日\D+(\d+):(\d+)}) } ); $data->end('') if ( $data->end->m(qr{0/0})->[0]); $data->pushme($data); } 1; } { package FletsFailure::NTTWest; use Web::Scraper; use UNIVERSAL qw(isa); use URI; use utf8; sub extract { my ( $class, $uri ) = @_; my $scraper = scraper { process 'td[width=500] a', 'url[]' => '@href'; result 'url'; }; my $urls = $scraper->scrape( URI->new($uri) ); map { my $rel = $_; $class->setup( URI->new_abs( $rel, $uri ) ) } @$urls if ( isa( $urls, 'ARRAY' ) ); } sub setup { my ( $class, $uri ) = @_; my ( $down, $desc, $listref ); my $text = scraper { process 'b', 'area' => 'TEXT'; process 'pre', 'text' => 'TEXT'; result 'area', 'text'; }; my $data = new FletsFailure::Data; $down = $text->scrape($uri); $$down{text} =~ tr/０-９：（）Ａ-Ｚａ-ｚ /0-9:()A-Za-z /; $desc = $$down{text}->m(qr{影 響:([^。]+)}s)->[0]; $desc->s( qr{原 因.+$}, "" ); $desc->sg( qr{\s+}, "" ); $data->url($uri); $data->area( $$down{area}->m(qr{（(.+)）})->[0] ); $data->begin( sprintf "%d/%d %02d:%02d", @{ $$down{text}->m(qr{発生日時:(.+)\n}m)->[0] ->m(qr{(\d+)月\s*(\d+)日\D+\s*(\d+):(\d+)}) } ); eval { $data->end( sprintf "%d/%d %02d:%02d", @{ $$down{text}->m(qr{回復日時:(.+)\n}m)->[0] ->m(qr{(\d+)月\s*(\d+)日\D+\s*(\d+):(\d+)}) } ); }; $data->end('') if $@; $data->type( $desc->m(qr{Bフレッツ・?サービス})->[0] + $desc->m(qr{フレッツ・?シリーズサービス})->[0] * 2 + $desc->m(qr{フレッツ・?ISDNサービス})->[0] * 4 + $desc->m(qr{フレッツ・?ADSLサービス})->[0] * 8 ); $data->pushme($data); } 1; } use YAML qw(LoadFile DumpFile); use DateTime; use DateTime::Duration; use Net::Twitter; use Encode qw(_utf8_off); my ( $config, $hash, %digest ); my ( $dt, $today, $twit ); eval { $config = LoadFile("config.yml") }; die "config.yml not found\n" if $@; eval { $hashes = LoadFile("hashes.yml") }; $dt = DateTime->now( time_zone => 'Asia/Tokyo' ); $today = $dt->month . '/' . $dt->day; map { my $url = $_; FletsFailure::NTTEast->extract($url); } @{ $$config{NTTEast} }; map { my $url = $_; FletsFailure::NTTWest->extract($url); } @{ $$config{NTTWest} }; $twit = Net::Twitter->new( username => $$config{userid}, password => $$config{passwd} ); my $list = new FletsFailure::Data; map { my ( $data, $digest, $str ); $info = $_; $digest = $info->digest; $digest{$digest} = $info->url; if ( ( $hashes && !$$hashes{$digest} ) || ( !$hashes && ( !$info->end || $info->end->m(qr{$today})->[0] ) ) ) { $str = $info->msg; _utf8_off($str); $twit->update($str); } } ( @{ $list->list } ); DumpFile( "hashes.yml", \%digest );
