#!/usr/bin/perl
BEGIN {
	require "fatlib.pl";
}

use utf8;
use strict;

my $VER="V.1.008n(nanakochi123456)";
my $tarball="denkiyohou111204.tar.gz";
my $adminmail='nanami@daiba.cx';
my $adminname='でんき予報速報管理人';
my $date_format="Y-m-d H:i:s";

my $data_update=<<EOM;
<li>2011/6/23 07:23 節電の心得を追加した</li>
<li>2011/6/20 16:00 仮データのみ登録</li>
EOM

my $engine_update=<<EOM;
<li>2011/12/03 14:50 今更ですが、Windows ガジェットに対応した。</li>
<li>2011/8/08 11:40 0時に再び翌日の見通しが配信されるのを修正</li>
<li>2011/8/04 13:33 小数点1桁まで％表示をするようにした。</li>
<li>2011/7/15 16:00 速報のメールのタイトルを変更した。</li>
<li>2011/7/12 22:10 速報のHTMLタグがきちんとしていなかったのを修正した。</li>
<li>2011/7/08 13:15 IE9対策のために、Twitterのハッシュタグをプロクシ動作をさせた。</li>
<li>2011/7/08 04:11 Twitterのポストに、過去に使用していた。#jishin_power ハッシュタグを追加した。</li>
<li>2011/7/06 21:40 8時～21時の5分おきのデータを自動ツィートするようにした。</li>
<li>2011/7/04 05:18 こちらのスクリプト側には変更がないですが、その他サービスの東京電力使用量（１時間おき）をPCのみ、任意指定日付表示、及び、2008年の分から表示するようにしました。</li>
<li>2011/7/01 17:30 電力使用量の使い勝手を良くし、かつ色を使用率ごとに変更した。また、再びメール送信ポリシーを１日最大４回と変更いたしました。</li>
<li>2011/7/01 14:00 5分ごとの電力使用量を閲覧できるようにした。(PCのみ)</li>
<li>2011/7/01 11:45 ごくわずかにデザインを変更し、メールサンプルを追加した。</li>
<li>2011/7/01 09:32 全機能の搭載が完了致しました。クエリーに ?tclock を入れると tclock2ch用のテキスト(ShiftJIS)、?text を入れると テキストフォーマット、?html を入れると、HTML挿入用（PC向け)、?mhtml を入れるとHTML挿入用(モバイル向け)、?rss を入れるとRSSフィールドが出力されます。<br />また、メール送信ポリシーを、前日の見通しの95%以上と相当されるもの（3段階目）、及び、5分おきに95%以上、99%以上を出力するようにしました。</li>
<li>2011/6/30 18:02 見通し（最終表示）がバグっていたのを修正。</li>
<li>2011/6/23 07:23 メール送信のポリシーを変更した。</li>
<li>2011/6/22 04:37 東京電力の１７：３０に発表する見通しに対応した。</li>
<li>2011/6/21 14:22 モバイルの登録を空メール送信方式に変更した。ただし自家サーバー経由ですので、計画停電が万が一発生した場合、登録にしばらく時間がかかることがあります。</li>
<li>2011/6/21 05:40 RSSに対応</li>
<li>2011/6/20 21:40 計画停電で使用していたfatlib.pl の不要部分を削除した。</li>
<li>2011/6/20 20:00 メールアドレスをDNS参照でドメインを確認するようにした。</li>
<li>2011/6/20 16:00 メール登録機能、登録解除機能のみ実装した。</li>
EOM

my $tclock_update=<<EOM;
<li>2011/6/20 21:40 ログファイルをデフォルトで作らないようにした。</li>
<li>2011/6/20 10:00 新規作成</li>
EOM

#------------
use CGI;
use Jcode;
use Nana::Mail;
use Nana::YukiWikiDB;
use Encode;
use HTTP::Lite;
use Digest::MD5 qw(md5_hex);
my $debug;

require "common.pl";

$VER=~s/\(.*//g;

my $body;

my($basehref, $basehost, $basepath)=&getbasehref;
my $cache="./cache";
my $date=&date("Y-m-d");
my $hour=&date("H");
my $logfile="$cache/usage-$date.log";

if($ENV{QUERY_STRING}=~/cmd\=twitter\_proxy/) {
	&twitter_proxy;
	exit;
}

if($ENV{QUERY_STRING} eq "tclock") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	my $header="=========================■ 東京電力電気速報 ■=========================\n";
	print Jcode->new($header)->sjis;
	if(open(R,"cache/sokuhou.txt")) {
		my $buf;
		foreach(<R>) {
			$buf.=$_;
		}
		print Jcode->new($buf)->sjis;
		close(R);
	}
	exit;
}
if($ENV{QUERY_STRING} eq "text") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	my $header="■ 東京電力電気速報 ■\n";
	print Jcode->new($header)->sjis;
	if(open(R,"cache/sokuhou.txt")) {
		my $buf;
		foreach(<R>) {
			$buf.=$_;
		}
		print Jcode->new($buf)->sjis;
		close(R);
	}
	exit;
}

if($ENV{QUERY_STRING} eq "allcompany") {
	my @files=(
		"/home/ymda/htdocs/denki/cache/sokuhou.short",
		"/home/ymda/htdocs/denki.h/cache/sokuhou.short",
#		"/home/ymda/htdocs/power/cache/cepco.short",
		"/home/ymda/htdocs/denki.c/cache/sokuhou.short",
		"/home/ymda/htdocs/denki.k/cache/sokuhou.short",
		"/home/ymda/htdocs/denki.u/cache/sokuhou.short",
	);
	my $out;
	foreach(@files) {
		if(open(R,"$_")) {
			foreach(<R>) {
				chomp;
				$out.="$_";
			}
			$out.="\n";
			close(R);
 		}
	}
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	print Jcode->new($out)->sjis;
	exit;
}

if($ENV{QUERY_STRING} eq "gadget_allcompany") {
	my @files=(
		"/home/ymda/htdocs/denki/cache/sokuhou.gadget",
		"/home/ymda/htdocs/denki.h/cache/sokuhou.gadget",
		"/home/ymda/htdocs/denki.c/cache/sokuhou.gadget",
		"/home/ymda/htdocs/denki.k/cache/sokuhou.gadget",
		"/home/ymda/htdocs/denki.u/cache/sokuhou.gadget",
	);
	my $out;
	foreach(@files) {
		if(open(R,"$_")) {
			foreach(<R>) {
				chomp;
				$out.="$_";
			}
			$out.="\n";
			close(R);
 		}
	}
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	print Jcode->new($out)->utf8;
	exit;
}

if($ENV{QUERY_STRING} eq "gadget_lastmod") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	my ($sec, $min, $hour, $day, $mon, $year, $weekday) = localtime(time);
	$sec="0$sec" if($sec<10);
	$min="0$min" if($min<10);
	$hour="0$hour" if($hour<10);
	print "$hour:$min:$sec";
	exit;
}

if($ENV{QUERY_STRING}=~/^gadget_ad(\d+)/) {
	my $num=$1;
	my @AD;
	if(open(R,"ad.html")) {
		foreach(<R>) {
			s/[\r\n]//g;
			push(@AD,$_);
		}
		close(R);
	}
	if($#AD>=0) {
		$num=$num % ($#AD+1);
	}
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

$AD[$num]
EOM
	exit;
}

if($ENV{QUERY_STRING} eq "gadget_body") {
	my $buf;
	if(open(R,"body.html")) {
		foreach(<R>) {
			s/[\r\n]//g;
			$buf.="$_\n";
		}
		close(R);
	}
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

$buf
EOM
	exit;
}

if($ENV{QUERY_STRING} eq "gadget_css") {
	my $buf;
	if(open(R,"pwcss.css")) {
		foreach(<R>) {
			s/[\r\n]//g;
			$buf.="$_\n";
		}
		close(R);
	}
	print <<EOM;
Content-type: text/css
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

$buf
EOM
	exit;
}

if($ENV{QUERY_STRING} eq "gadget_js") {
	my $buf;
	if(open(R,"pwjs.js")) {
		foreach(<R>) {
			s/[\r\n]//g;
			$buf.="$_\n";
		}
		close(R);
	}
	print <<EOM;
Content-type: application/javascript
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

$buf
EOM
	exit;
}

if($ENV{QUERY_STRING} eq "html") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	if(open(R,"cache/sokuhou.html")) {
		my $buf;
		foreach(<R>) {
			$buf.=$_;
		}
		print Jcode->new($buf)->sjis;
		close(R);
	}
	exit;
}

if($ENV{QUERY_STRING} eq "mhtml") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	if(open(R,"cache/sokuhou.mhtml")) {
		my $buf;
		foreach(<R>) {
			$buf.=$_;
		}
		print Jcode->new($buf)->sjis;
		close(R);
	}
	exit;
}

if($ENV{QUERY_STRING} eq "twitter") {
	print <<EOM;
Content-type: text/plain
Cache-Control: max-age=0
Expires: Mon, 26, Jul 1997 05:00:00 GMT

EOM
	if(open(R,"cache/sokuhou.twitter")) {
		my $buf;
		foreach(<R>) {
			$buf.=$_;
		}
		print Jcode->new($buf)->sjis;
		close(R);
	}
	exit;
}

my $rssdate;
my $rssupdate;
my $rss;
my $mitoushi;

if($ENV{QUERY_STRING} eq "rss") {
	&gzip_compress("Content-type: text/html; charset=utf-8\nCache-Control: max-age=0\nExpires: Mon, 26, Jul 1997 05:00:00 GMT");
	if(open(R,"cache/sokuhou.xml")) {
		foreach(<R>) {
			print $_;
		}
		close(R);
	}
	close(STDOUT);
	exit;
}

my $nojapaneseflg=0;
#$nojapaneseflg=1 if($ENV{HTTP_ACCEPT_LANGUAGE}!~/ja/);
my $mobileflg=0;
$mobileflg=1 if($ENV{HTTP_USER_AGENT}=~/DoCoMo|UP\.Browser|KDDI|SoftBank|Voda[F|f]one|J\-PHONE|DDIPOCKET|WILLCOM|iPod|PDA|Mobile|Semulator/);

$mobileflg=0 if($ENV{QUERY_STRING}=~'p');
$mobileflg=1 if($ENV{QUERY_STRING}=~'m');
$nojapaneseflg=0 if($ENV{QUERY_STRING}=~'j');
#$nojapaneseflg=1 if($ENV{QUERY_STRING}=~'e');

my $query=new CGI;

my $mode=$query->param('m');
my $qr=$query->param('qr');

if($mode eq 'qr') {
	my $string=$query->param('str');
	&make_qrcode($string,$qr);
	exit;
}

my $file;
my @data;
my $hash;
my $mailfile;
my $subject;
my %db;
my $english_file="english.html";
my $english_mobile_file="english_mobile.html";
my $mobile_file="mobile.html";
my $pc_file="pc.html";
my $mobile_update_file="mobile_update.html";
my $mobile_setuden_file="mobile_setuden.html";
my $mobile_mailsample_file="mobile_mailsample.html";
my $mobile_twitter_file="mobile_twitter.html";
my $mobile_announce_file="mobile_announcement.html";

my $mail=$query->param('mail');
my $err;
if($mail ne '') {
	if(&mailchk($mail)) {
		my $mode;
		my $regunreg=$query->param('m');
		my $regist=$query->param('regist');
		my $unregist=$query->param('unregist');
		if($regist ne '' || $regunreg eq "regist") {
			$mode="regist";
		} elsif($unregist ne '' || $regunreg eq "unregist") {
			$mode="unregist";
		} else {
			$err="リクエストが異常です。";
			$file="error.html";
		}
		if($file eq '' && $mode eq "regist") {
			&open_db;
			@data=split(/\n/,$::database{$mail});
			foreach(@data) {
				my ($name,$value)=split(/=/,$_);
				$db{$name}=$value;
			}
			if($db{"registed"} eq 1) {
				&close_db;
				$file="error.html";
				$err="このメールアドレスは登録されています。";
			} elsif($::database{$mail} eq '') {
				$file="regist.html";
				$hash=md5_hex($mail . time . $ENV{REMOTE_ADDR});
				$mailfile="registconfirmmail.txt";
				$subject="でんき予報メール仮登録のお知らせ";
				$::database{$mail}=<<EOM;
mail=$mail
confirm=1
hash=$hash
EOM
				&close_db;
			}
		} elsif($file eq '' && $mode eq "unregist") {
			&open_db;
			@data=split(/\n/,$::database{$mail});
			foreach(@data) {
				my ($name,$value)=split(/=/,$_);
				$db{$name}=$value;
			}
			if($db{"confirm"}  eq 1) {
				$file="confirmnow.html";
			} elsif($db{"registed"} eq 1) {
				$file="unregist.html";
				$mailfile="unregistconfirmmail.txt";
				$subject="でんき予報メール仮登録解除のお知らせ";
				$::database{$mail}=<<EOM;
mail=$db{mail}
registed=1
hash=$db{hash}
EOM
				$hash=$db{hash};
			} else {
				$err="登録されていないメールアドレスです。";
				$file="error.html";
			}
			&close_db;
		}
	} else {
		$err="メールアドレスが正しくありません。";
	}
}

my $qhash=$query->param('x');
my $mode=$query->param('mode');

if($mode eq "confirm" && $qhash ne '') {
	&open_db;
	foreach my $email(keys %::database) {
		@data=split(/\n/,$::database{$email});
		foreach(@data) {
			my ($name,$value)=split(/=/,$_);
			$db{$name}=$value;
		}
		if($db{"confirm"} eq 1 && $db{"hash"} eq $qhash && !defined($db{"registed"})) {
			$::database{$email}=<<EOM;
mail=$db{mail}
registed=1
hash=$db{hash}
EOM
			$mail=$db{mail};
			$file="regist_confirm.html";
			$mailfile="registmail.txt";
			$subject="でんき予報メール登録のお知らせ";
			&close_db;
			Nana::Mail::toadmin("Add",$mail,$adminmail);
 			last;
		}
		foreach (keys %db) {
			delete $db{$_};
		}
	}
	if($mail eq '') {
		$err="メールアドレスが正しくないか、メールに添付されたアドレスにきちんとアクセスできていません。";
		$file="error.html";
	}
}

if($mode eq "unregistconfirm" && $qhash ne '') {
	&open_db;
	foreach my $email(keys %::database) {
		@data=split(/\n/,$::database{$email});
		foreach(@data) {
			my ($name,$value)=split(/=/,$_);
			$db{$name}=$value;
		}
		if($db{"registed"} eq 1 && $db{"hash"} eq $qhash) {
			$mail=$db{mail};
			delete $::database{$mail};
			$file="unregist_confirm.html";
			$mailfile="unregist.txt";
			$subject="でんき予報メール登録解除完了のお知らせ";
			&close_db;
			Nana::Mail::toadmin("Del",$mail,$adminmail);
			last;
		}
	}
	if($mail eq '') {
		$err="メールアドレスが正しくないか、メールに添付されたアドレスにきちんとアクセスできていません。";
		$file="error.html";
	}
}

&gzip_compress("Content-type: text/html; charset=utf-8\nCache-Control: max-age=0\nExpires: Mon, 26, Jul 1997 05:00:00 GMT");

my $kanaflg=0;
my $updatetitle;
if($file eq '') {
	if($nojapaneseflg) {
		if($mobileflg) {
			$file=$english_mobile_file;
		} else {
			$file=$english_file;
		}
	} elsif($ENV{QUERY_STRING}=~/^mju/) {
		$file=$mobile_update_file;
		$kanaflg=1;
	} elsif($ENV{QUERY_STRING}=~/^mjs/) {
		$file=$mobile_setuden_file;
		$kanaflg=1;
	} elsif($ENV{QUERY_STRING}=~/^mja/) {
		$file=$mobile_announce_file;
		$kanaflg=1;
	} elsif($ENV{QUERY_STRING}=~/^mjt/) {
		$file=$mobile_twitter_file;
		$kanaflg=1;
	} elsif($ENV{QUERY_STRING}=~/^mjm/) {
		$file=$mobile_mailsample_file;
		$kanaflg=1;
	} elsif($mobileflg) {
		$file=$mobile_file;
	} else {
		$file=$pc_file;
	}
}

my $logdates=&logdates;

if(open(R,"<:utf8","$file")) {
	foreach(<R>) {
		$body.=&convert($_);
	}
	close(R);
} else {
	$body="$file not found. sorry.";
}
if($kanaflg) {
	$body=&z2h($body);
}
binmode(STDOUT, ":utf8");
print "$body$debug\n";
close(STDOUT);

if($mailfile ne '') {
	$body='';
	Nana::Mail::getremotehost;
	if(open(R,"<:utf8","$mailfile")) {
		foreach(<R>) {
			$body.=&convert($_);
		}
		close(R);
		Nana::Mail::send(
			to=>$mail, to_name=> $mail . "様",
			from=>$adminmail, from_name=>$adminname,
			subject=>$subject,data=>$body);
	}
}
exit;

sub logdates {
	my $buf;
	my @tmp;
	my @logdates;
	if(!opendir(DIR,$cache)) {
		print <<EOM;
Content-type: text/plain

$cache not found
EOM
	}
	while(my $file=readdir(DIR)) {
		if($file=~/usage\-(\d+)-(\d+)-(\d+)\.log$/) {
			push(@tmp,"$1-$2-$3");
		}
	}
	closedir(DIR);
	@tmp=reverse sort @tmp;
	foreach(@tmp) {
		my($year,$mon,$day)=split(/-/,$_);
my $date=&date("Y-m-d");
my $hour=&date("H");
		my $selected4="$date" eq $_ && $hour >= 18 ? " selected" : '';
		my $selected3="$date" eq $_ && $hour >= 12 ? " selected" : '';
		my $selected2="$date" eq $_ && $hour >= 6 ? " selected" : ''; 
		my $selected1="$date" eq $_ && $hour >= 0 ? " selected" : '';

		$buf.=sprintf("<option value=\"%04d-%02d-%02d-00\"$selected1>%04d年%02d月%02d日 0時～5時台</option>"
			, $year,$mon, $day, $year,$mon, $day);
		$buf.=sprintf("<option value=\"%04d-%02d-%02d-06\"$selected2>%04d年%02d月%02d日 6時～11時台</option>"
			, $year,$mon, $day, $year,$mon, $day);
		$buf.=sprintf("<option value=\"%04d-%02d-%02d-12\"$selected3>%04d年%02d月%02d日 12時～17時台</option>"
			, $year,$mon, $day, $year,$mon, $day);
		$buf.=sprintf("<option value=\"%04d-%02d-%02d-18\"$selected4>%04d年%02d月%02d日 18時～23時台</option>"
			, $year,$mon, $day, $year,$mon, $day);

	}
	return $buf;
}

sub convert {
	my($text)=shift;
	if(/\@\@/) {
		$text=~s/\@\@VER\@\@/$VER/;
		$text=~s/\@\@ERR\@\@/$err/;
		$text=~s/\@\@INCLUDE\=\"(.+)\"\@\@/@{[&include($1)]}/;
		$text=~s/\@\@INCLUDESCRIPT\=\"(.+)\"\@\@/@{[&include($1,1)]}/;
		$text=~s/\@\@QRCODEEN\@\@/@{[&qrcode_link_en]}/;
		$text=~s/\@\@QRCODEJP\@\@/@{[&qrcode_link]}/;
		$text=~s/\@\@DATAUPDATE\@\@/$data_update/;
		$text=~s/\@\@ENGINEUPDATE\@\@/$engine_update/;
		$text=~s/\@\@TCLOCKUPDATE\@\@/$tclock_update/;
		$text=~s/\@\@TARBALL\@\@/$tarball/;
		$text=~s/\@\@MAIL\@\@/$mail/;
		$text=~s/\@\@HASH\@\@/$hash/;
		$text=~s/\@\@URL\@\@/$basehost$basepath/;
		$text=~s/\@\@REMOTE_ADDR\@\@/$ENV{REMOTE_ADDR}/;
		$text=~s/\@\@REMOTE_HOST\@\@/$ENV{REMOTE_HOST}/;
		$text=~s/\@\@DATETIME\@\@/@{[&date($date_format)]}/;
		$text=~s/\@\@RSS\@\@/$rss/;
		$text=~s/\@\@RSSDATE\@\@/$rssdate/;
		$text=~s/\@\@RSSUPDATE\@\@/$rssupdate/;
		$text=~s/\@\@MITOUSHI\@\@/$mitoushi/;
		$text=~s/\@\@DATES\@\@/$logdates/;
	}
	return $text;
}

sub include {
	my ($file,$mode)=@_;
	my $body="";
	if(open(I,"<:utf8","$file")) {
		my $div=$file;
		$div=~s/\.//g;
		$body.=<<EOM if($mode ne 1);
<div id="$div">
EOM
		foreach(<I>) {
			$body.=$_;
		}
		close(I);
		$body.="</div>\n" if($mode ne 1);
	}
	$body;
}

sub qrcode_link {
	my $string=&enc("$basehost$basepath");
	if(&load_module("GD") && &load_module("GD::Barcode")) {
		return <<FIN;
携帯へURLを送るには、こちらのQRコードをご利用下さい。<br />
<img alt="QRCode" src="$basehost$basepath/?m=qr\&amp;str=$string" />

FIN
	}
	'';
}

sub twitter_proxy {
	my $query=new CGI;
	my $rpp=$query->param('rpp');
	my $q=&enc($query->param('q'));
	my $near=$query->param('near');
	my $within=$query->param('widhin');
	my $units=$query->param('units');
	my $since_id=$query->param('since_id');
	my $callback=$query->param('callback');

	my $searchurl="http://search.twitter.com/search.json";
	$searchurl.="?rpp=$rpp&callback=$callback&q=$q";
	my ($status,$stream)=&httpcl($searchurl);

	if($status eq 0) {
		&gzip_compress("Content-type: application/json");
		print $stream;
	} else {
		print "Content-type: text/plain\n\n";
		print "Cant get '$searchurl'\n";
	}
	exit;
}