NeverBlog::Likk::Unexistable;

見なかったことにして下さい

電車情報メール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が見合ってないような気がして、二の足を地団太ふみふみ状態><。