トップ > Technical Notes > 旧文書 > 天気予報をゲットだぜ

天気予報をゲットだぜ

Perlソース

perl で直に http を喋り、適当なパースをするためのソースです。

perl には、HTTP::* というモジュールが用意されていて、簡単にウェブサイト上の情報を取り込むことができるようになっていますが、汎用性を重視したあまりに動作速度がきわめて遅くなっているのが欠点です。そこで、get_html($url, $email); という関数を定義しています。2番目の引数は、User-Agent の一部として表示される電子メールアドレスです。

パース結果を保存するためにデータベースを使っていますが、ファイルで十分という人は、最後の db_update 関数を変形すればよさそうですね。

#!/usr/bin/perl
#
#  weather.crc.co.jp から岡山県南部の天気予報をとってくる。
#
#  ちょっと賢い & MySQL利用バージョン
#  by Norihisa Washitake, nori@washitake.com
#
#  Copyright (C) 2001, Norihisa Washitake.
# 		当然データの Copyright は主張しませんが、
# 		プログラム部分には Copyright を主張します。
#
#  地方を変える場合は、この下の $url 部分を適当に
#  変えてください。

use Socket;
use DBI;
require 'jcode.pl';

my $url = "http://weather.crc.co.jp/short/s6620.html";
my $mail_addr = 'YOUR_MAIL_ADDRESS';

# HTTP で天気予報を取ってくる
my @source = &get_html($url, $mail_addr);
if (scalar(@source) == 0) {
	die "Source is empty.";
}

# 日付をとりあえず用意
my @max_day = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
my @time = localtime(time());
my $year = 1900 + $time[5];
$max_day[1] = (($year % 4 == 0)  && ($year % 100 != 0) && ($year % 400 == 0)) ? 29 : 28;

# 構造解析
my @output = ();
my $mode = 0;
my $line = "";

foreach $line (@source) {
	# とりあえず改行文字はとっておく (お約束)
	$line =~ s/\x0a//;
	$line =~ s/\x0d//;

	# 行の内容から、どんな行なのかを判別
	if ($line =~ /^<tr><td><img src=\"..\/image\/frame\/1p.gif\"><\/td>/) {
		$mode = 1;
	} elsif ($line =~ /^<tr><td>天気/) {
		$mode = 2;	 #　　　　天気の行(一番大事)
	} elsif ($line =~ /^<tr><td>最高気温/) {
		$mode = 3;	 # 最高気温
	} elsif ($line =~ /^<tr><td>最低気温/) {
		$mode = 4;	 # 最低気温
	} elsif ($line =~ /<td rowspan=2>降水確率/) {
		$mode = 5;	 # ' : 4つずつ、無効な '—'
	} elsif ($line =~ /(\d+)年(\d+)月(\d+)日(\d+)時発表/) {
		$month = $2 + 0;
		$day = $3 + 0;
		$day_next = ($max_day[$month - 1] <= $day) ? 1 : $3 + 1;
		$hour = $4;
	}

	# 複数行にわたっても大丈夫なように、モードごとに連結
	$output[$mode - 1] .= $line if ($mode > 0);

	if ($line =~ /<\/tr>/) {
		$mode = 0 if ($mode < 5 || $mode == 6);
		$mode = 6 if ($mode == 5);
	}
}

$output[4] .= $output[5];
$output[5] = "";

# 要らない情報は削除
foreach $line (@output) {
	$line =~ s/<\/?[^>]+>/ /g;
	$line =~ s/—/-/g;
	$line =~ s/\%/ /g;
	$line =~ s/ +/ /g;
	$line =~ s/^ //;
	$line =~ s/ +$//;
}

# ここから、各要素を取り出したり計算したり。
my @items = ();
@items = split(/ /, $output[1]); $tenki = 	($items[2] ne '-') ? $items[2] : '不明';
@items = split(/ /, $output[2]); $high_temp = ($items[2] ne '-') ? $items[2].'℃' : '不明';
@items = split(/ /, $output[3]); $low_temp	= ($items[2] ne '-') ? $items[2].'℃' : '不明';

# 天気マーク用文字列の作成
my %marknam = (
	'晴', 1, '曇り', 2, '雨', 3, '雪', 4,
	'時々', 1, '後', 2,
	'!', 0
);
if ($tenki =~ /(.+)(後)(.+)/) {
	$mark1 = $1;	$mark2 = $2; $mark3 = $3;
} elsif ($tenki =~ /(.+)(時々)(.+)/) {
	$mark1 = $1;	$mark2 = $2; $mark3 = $3;
} else {
	$mark1 = $1;	$mark2 = '!'; $mark3 = '!';
}
my $tenki_mark = $marknam{$mark1} . $marknam{$mark2} . $marknam{$mark3};

# 1日での降水確率を計算
@items = split(/ /, $output[4]);
my $cnt = 0;
my $sum = 0;
for ($i=13; $i<17; $i++) {
	if ($items[$i] ne '-') {
		$cnt++;
		$sum += (0 + $items[$i]);
	}
}
my $rainf = ($cnt>0) ? ($sum > 0) ? int($sum / $cnt / 10) .'0％' : '0％' : '不明';

# データベースに登録
my $db = DBI->connect('DBI:mysql:database:hostname', 'username', 'password');
db_update($db, 'day', $day);
db_update($db, 'day_next', $day_next);
db_update($db, 'hour', $hour);
db_update($db, 'mark', $tenki_mark);
db_update($db, 'tenki', $tenki);
db_update($db, 'h_temp', $high_temp);
db_update($db, 'l_temp', $low_temp);
db_update($db, 'rainf', $rainf);
$db->disconnect;


####	ここからは汎用関数群。

sub get_html($$)
{
	my $full_uri = shift;
	my $mail_addr = shift;

	# by 大崎さんの perl メモ によるメールアドレスのパタンマッチ
	my $mail_regex =
	q{(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\} .
	q{\[\]\000-\037\x80-\xff])|"[^\\\\\x80-\xff\n\015"]*(?:\\\\[^\x80-\xff][} .
	q{^\\\\\x80-\xff\n\015"]*)*")(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x} .
	q{80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff])|"[^\\\\\x80-} .
	q{\xff\n\015"]*(?:\\\\[^\x80-\xff][^\\\\\x80-\xff\n\015"]*)*"))*@(?:[^(} .
	q{\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\0} .
	q{00-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[^\x80-\xff])*} .
	q{\])(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,} .
	q{;:".\\\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[} .
	q{^\x80-\xff])*\]))*};

	if ($full_uri !~ /s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+/) {
		die "Malformed URI : ${full_uri}\n";
	}
	if ($mail_addr !~ /^$mail_regex$/o) {
		die "Malformed mail address : ${mail_addr}\n";
	} elsif ($mail_addr eq 'nori@washitake.com') {
		print "You are not me!! Change the mail address!\n";
		print "Aborted.\n";
		exit -12345;
	}

	my @html_buf = ();

	# HTTPプロトコルのバージョン
	$http = '1.1';

	# URL解析処理
	$full_uri =~ /(http:)?(\/\/)?([^:\/]*)?(:([0-9]+))?(\/.*)?/;
	my $host = $3;
	my $port = $5;
	my $path = $6;
	if ($host eq '') { $host = 'localhost'; }
# 		if ($port eq '') { $port = getservbyname('http', 'tcp'); }
	if ($port eq '') { $port = '80'; }
	if ($path eq '') { $path = '/'; }

	my $con_host = $host;
	my $con_port = $port;
	my $url = $path;

	# ソケットの生成
	my $ip = inet_aton($con_host)
		or die "host($con_host) not found.\n";
	my $sockaddr = pack_sockaddr_in($con_port, $ip);
	socket(SOCKET, PF_INET, SOCK_STREAM, 0)
		or die "socket error.\n";

	# ソケットの接続
	connect(SOCKET, $sockaddr)
		or die "connect $con_host $con_port error.\n";
# 		autoflush SOCKET (1);
	select(SOCKET); $|=1; select(STDOUT);

	# HTTP要求を送信
	if ($http == 1.1) {
		print SOCKET "GET $url HTTP/1.1\n";
		print SOCKET "Connection: close\n";
		print SOCKET "Host: $host\n";
		print SOCKET "User-Agent: wassy's perl [1.0, used by ${mail_addr}] see washitake.com\n";
		print SOCKET "\n";

		if ($debug != 0) {
			print "< GET $url HTTP/1.1\n";
			print "< Connection: close\n";
			print "< Host: $host\n";
			print "< User-Agent: wassy [nori\@washitake.com]\n";
			print "\n";
		}
	} else {
		print SOCKET "GET $url HTTP/1.0\n\n";
		print "< GET $url HTTP/1.0\n\n" if ($debug != 0);
	}

	# HTTP ヘッダは無視。
	while (<SOCKET>) {
		if ($debug > 0) { print ">> ", $_; }
		m/^\r\n$/ && last;
	}

	# HTTP応答を受信
	while (<SOCKET>) {
		push @html_buf, $_;
	}

	# 終了処理
	close(SOCKET);

	return @html_buf;
}

sub db_update
{
	my $data_base = shift;
	my $sql_key = shift;
	my $sql_val = shift;

	my $sql = $data_base->prepare("update weather set value='$sql_val' where name='$sql_key'");
	$sql->execute;
	$sql->finish;
}
__END__