電車情報メール2 WWW::TrainInfo::TokyoMetoro;
[Perl] 電車が遅れたらメールで通知 WWW::TrainInfo::JREast; - NeverBlog::Likk::Unexistable; 念願のroot権限を手にいれたぞの東京メトロ版
WWW::TrainInfo::JREast とほぼ互換性があると思います。
叩き台というか、ほぼ未完成状態だが貼り付け
package WWW::TrainInfo::TokyoMetoro; use strict; use warnings; use URI; use Web::Scraper; use DateTime; our $VERSION = '0.1'; our $BASE_URL = "http://www.tokyometro.jp"; our $INFO_URL = "/unkou/top.shtml"; our $AREA_DATA = { 'g' => { 'name' => '銀座線', }, 'm' => { 'name' => '丸ノ内線', }, 'h' => { 'name' => '日比谷線', }, 't' => { 'name' => '東西線', }, 'c' => { 'name' => '千代田線', }, 'y' => { 'name' => '有楽町線', }, 'z' => { 'name' => '半蔵門線', }, 'n' => { 'name' => '南北線', }, }; sub new{ my $class = shift; my %c = @_; my $self = { area => $c{area} || [qw(g m h t c z y n)], notify_no_delay => $c{notify_no_delay} ||0, test_news => $c{test_news} ||'' }; bless $self,$class; } sub get_info{ my $self = shift; my $area_ref = $self->{area}; my $total_record = (); my $area_result = (); my $metoro =""; my $target_url = $BASE_URL.$INFO_URL; #配信情報取得 my $scraper = scraper { process "div#contentsArea>div>table>tbody>tr>td", 'line[]' => 'HTML'; #データが面倒な形なのでHTMLベースで取得 result 'line'; }; $metoro = $scraper->scrape(URI->new($target_url)); my @extract = (); for (@$metoro){ utf8::encode($_); } #路線名+情報 になるようにgrepしてjoinしてsplit @extract = grep{ m#(src="/unkou/img/|<span class=)#g } @$metoro; my $extract_l = join '',@extract; @extract = split m#</span></div><div><img alt="" height="5" src="/common/img/sp.gif" width="1" /></div># ,$extract_l; for my $linec (@$area_ref){ my @line_info = grep {/$AREA_DATA->{$linec}->{name}/}@extract; if($line_info[0] !~ /現在、平常どおり運転しています。/){ my $description = $1||'' if $line_info[0] =~ m#^(?:.*)?<span class="red">(.*)$#; $description =~ s{<br />}{}g;#不要なタグの除去 my $dt = DateTime->now(); #必要なら、現在の時刻で平常の情報をセット $dt->set_time_zone("Asia/Tokyo"); my $line_name = $AREA_DATA->{$linec}->{name}; my $delay_flg ||= 1 if $description =~ m/【遅延】/; my $stop_flg ||= 1 if $description =~ m/運転を見合わせ/; my $sleep_flg ||= 1 if $description =~ m/運休/; my $record = { year => $dt->year(), month =>$dt->month(), day =>$dt->day(), hour =>$dt->hour(), min =>$dt->min(), delay_flg => $delay_flg || 0, stop_flg => $stop_flg || 0, sleep_flg => $sleep_flg || 0, line_name => $line_name, area => $AREA_DATA->{$linec}->{name}, description => $description, }; push @$total_record,$record; }else{ next if $self->{notify_no_delay} == 0; #平常通りのアナウンスが不要ならnext。 my $dt = DateTime->now(); #必要なら、現在の時刻で平常の情報をセット $dt->set_time_zone("Asia/Tokyo"); my $date = $dt->year(); my $record = { year => $dt->year(), month =>$dt->month(), day =>$dt->day(), hour =>$dt->hour(), min =>$dt->min(), nomal_flg => 1, area => $AREA_DATA->{$linec}->{name}, description => '現在、平常どおり運転しています。', }; $area_result->{$AREA_DATA->{$linec}->{name}} = $line_info[0]; push @$total_record,$record; } } return $total_record; } 1;
呼び出し側のスクリプトは、ほぼ同じ。
#!/usr/bin/perl package main; use strict; use warnings; use WWW::TrainInfo::TokyoMetoro; use Unicode::Japanese; my @target_areas = qw(g m h t c z y n); my $delay = WWW::TrainInfo::TokyoMetoro->new( notify_no_delay => 0, area => [@target_areas] ); my $result = $delay->get_delay(); #以下略
codereposに上げた方がいいのかなーとは思うんですが、自分のPerlLVが見合ってないような気がして、二の足を地団太ふみふみ状態><。