Cyber EarthのPerl-20110713版

Cyber EarthのPerl初版(id:kazkun:20110711)を修正、キャッシュモード用CGIも移植し、一応の完成になりました。
日記にソースをウダウダ書くのもどうかと思ったんですけど、面倒なのでここに全コード貼りつけておきます。そのうちcode.googleとかgithubとか考えます。

cyber-earth.cgi

#!/usr/bin/perl
# Cyber Earth - The CyberJapan Map layer CGI for Google Earth.
# 
# Gauche version is written by YOKOTA Hiroshi 2008-07-28
#       http://www.netlab.is.tsukuba.ac.jp/~yokota/izumi/cyber-earth/
# Perl version is ported by Kazkun
# 
# Copyright pending because there is no response from Original author YOKOTA to date.
#
# 20110711 Kaz : Initial release on Perl
#                ADD ALPHA parameter, MODE parameter
#                MOD fixed for new format of CyberJapan site
# 20110713 Kaz : Cleanup code.

use strict;
use warnings;
use POSIX;
use CGI;
use List::Util qw(max min);

my $MYURLBASE = "http://localhost/cyberearth/";

sub toSecond100 {
	my ($val) = @_;
	return $val * (60 * 60 * 100.0);
}

sub toDegree {
	my ($val) = @_;
	return $val / (60 * 60 * 100.0);
}

sub isAvailableArea {
	my ($lat, $lon, $level) = @_;
	return 0 if $lon < toSecond100(121.0) - $level || $lon > toSecond100(154.0);
	return 0 if $lat < toSecond100( 20.2) - $level || $lat > toSecond100( 46.5);
	return 1;
}

sub makePosList {
	my ($start, $limit, $step) = @_;
	my ($i, @list);
	for($i = $start; $i < $limit; $i += $step) {
		unshift(@list, $i);
	}
	return @list;
}

sub adjustLevel {
	my ($lv) = @_;
	# avoid range bug. GoogleEarth puts wrong range value when the eye is very far from the earth. (Ver.4.1.7076.4458/Linux)
	return 3072000 if $lv <=       0;
	return     750 if $lv <=     750;
	return    1500 if $lv <=    1500;
	return    3000 if $lv <=    3000;
	return    6000 if $lv <=    6000;
	return   12000 if $lv <=   12000;
	return   24000 if $lv <=   24000;
	return   48000 if $lv <=   48000;
	return   96000 if $lv <=   96000;
	return  192000 if $lv <=  192000;
	return  384000 if $lv <=  384000;
	return  768000 if $lv <=  768000;
	return 1536000 if $lv <= 1536000;
	return 3072000;
	
}

sub levToLevID {
	my($lv) = @_;
	return "7.5fgd"       if $lv <=     750;
	return "15nti"        if $lv <=    1500;
	return "30nti"        if $lv <=    3000;
	return "60nti"        if $lv <=    6000;
	return "120bafd"      if $lv <=   12000;
	return "240bafd"      if $lv <=   24000;
	return "480bafd"      if $lv <=   48000;
	return "960bafd"      if $lv <=   96000;
	return "1920bafd"     if $lv <=  192000;
	return "raster/3840"  if $lv <=  384000;
	return "raster/7680"  if $lv <=  768000;
	return "raster/15360" if $lv <= 1536000;
	return "raster/30720";
}


# main logic starts here

my $query = new CGI;
my $mode = 0;
if ($query->param('MODE') == '1') {
	$mode = 1;
}
my $alpha = $query->param('ALPHA') + 0;
$alpha = 220 if ($alpha == 0);
my ($wdeg, $sdeg, $edeg, $ndeg) = split(/,/, $query->param('BBOX'));
my $wsec = toSecond100($wdeg + 0);
my $ssec = toSecond100($sdeg + 0);
my $esec = toSecond100($edeg + 0);
my $nsec = toSecond100($ndeg + 0);
my $lonsec = toSecond100($query->param('lookatLon') + 0);
my $latsec = toSecond100($query->param('lookatLat') + 0);
my $range = $query->param('lookatRange') + 0;
my $tilt = $query->param('lookatTilt') + 0;

# decide map level
my $level;
if ($tilt < 20) {
	$level = adjustLevel(max(abs($esec - $wsec), abs ($nsec - $ssec)) / 6);
} else {
	$level = adjustLevel($range / 4 * 3);		# FIXME : use $tilt
}

# reshape BoundBox
$wsec = max((floor($wsec/$level) - 1) * $level, (floor($lonsec/$level) - 3) * $level, toSecond100(0)),
$ssec = max((floor($ssec/$level) - 1) * $level, (floor($latsec/$level) - 3) * $level, toSecond100(-90)),
$esec = min((floor($esec/$level) + 1) * $level, (floor($lonsec/$level) + 4) * $level, toSecond100(360)),
$nsec = min((floor($nsec/$level) + 1) * $level, (floor($latsec/$level) + 4) * $level, toSecond100(90)), 

# build overlay position list
my @latlist = makePosList($ssec, $nsec, $level);
my @lonlist = makePosList($wsec, $esec, $level);
my @gridlist = ();
my $lat;
my $lon;
foreach $lat (@latlist) {
	foreach $lon (@lonlist) {
		push(@gridlist, [$lat, $lon]) if isAvailableArea($lat, $lon, $level);
	}
}

# setup misc data
my $color = sprintf("%02x", $alpha)."ffffff";
my $levstr = levToLevID($level);

# output XML data
print "Content-type: application/vnd.google-earth.kml+xml\n";
print "\n";
print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
print "<kml xmlns=\"http://earth.google.com/kml/2.0\">\n";
print "  <Document>\n";
print "    <Folder>\n";
print "      <name>layers</name>\n";
print "      <open>0</open>\n";
print "      <description>";
	print "MODE:" . ($mode == 1 ? "CACHED" : "DIRECT");
	print " ALPHA:$alpha";
	print " N:$ndeg E:$edeg W:$wdeg S:$sdeg Lev:$level";
	print " Nbox:" . toDegree($nsec);
	print " Ebox:" . toDegree($esec);
	print " Wbox:" . toDegree($wsec);
	print " Sbox:" . toDegree($ssec);
	print " lr:" . $query->param('lookatRange');
	print " llat:" . $query->param('lookatLat');
	print " llon:" . $query->param('lookatLon');
	print " lt:" . $query->param('lookatTilt');
print "</description>\n";

# output Overlay elements
my $pos;
foreach $pos (@gridlist) {
	my $lat = $pos->[0];
	my $lon = $pos->[1];
	my $path = "/data/$levstr/new/$lon/$lon-$lat-img.png";
	my $url;
	if ($mode < 1) {
		$url = "http://cyberjapandata.gsi.go.jp$path";
	} else {
		$url = "${MYURLBASE}cyber-earth-cache.cgi?filename=$path";
	}
	my $n = toDegree($lat + $level);
	my $s = toDegree($lat);
	my $e = toDegree($lon + $level);
	my $w = toDegree($lon);
	print "      <GroundOverlay>\n";
	print "        <name>$level:$lat:$lon</name>\n";
	print "        <color>$color</color>\n";
	print "        <Icon>\n";
	print "          <href>$url</href>\n";
	print "        </Icon>\n";
	print "        <LatLonBox>\n";
	print "          <north>$n</north>\n";
	print "          <south>$s</south>\n";
	print "          <east>$e</east>\n";
	print "          <west>$w</west>\n";
	print "        </LatLonBox>\n";
	print "      </GroundOverlay>\n";
}
print "    </Folder>\n";
print "  </Document>\n";
print "</kml>\n";
exit 0;

cyber-earth-cache.cgi

#!/usr/bin/perl
# Cyber Earth cache CGI.
# 
# Gauche version is written by YOKOTA Hiroshi 2008-07-28
#       http://www.netlab.is.tsukuba.ac.jp/~yokota/izumi/cyber-earth/
# Perl version is ported by Kazkun 2011-07-13
# 
# Copyright pending because there is no response from Original author YOKOTA to date.
#
# 20110713 Kaz : Initial release on Perl
#                MOD fixed for new format of CyberJapan site
#                MOD changed cache path to /tmp/FileCache/cyberearth
#                ADD ability to purge cache file automatically

use strict;
use warnings;
use CGI;
use LWP::UserAgent;
use MIME::Base64;
use Cache::SizeAwareFileCache;	# Cache-Cache module see http://search.cpan.org/~jswartz/Cache-Cache-1.06/

my $cache = Cache::SizeAwareFileCache->new({
#				'cache_root' => '/var/www/cyberearth/cache',	# cache dir
				'namespace' => 'cyberearth',
				'default_expires_in' => 60*60*2,	# two hours to expire
				'max_size' => 1024*1024*30			# 30Mbytes max
				});
my $query = new CGI;
my $ua = LWP::UserAgent->new;
$ua->agent("CyberEarth-cache/1.0p");				# name of User-Agent
#$ua->proxy('http', 'http://127.0.0.1:8080');		# uncomment and modify if use proxy server

my $isOfflineMode = -e "./cyber-earth-offline";		# if exists the file, this CGI becomes offline mode

# dummy image data encoded by base64
my $pngBroken = decode_base64("iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIEAYAAACUn2LIAAAABmJLR0T///////8JWPfcAAAACXBIWXMAAABIAAAASABGyWs+AAAAOklEQVQoz2P8/5+BgYEBQpIDWNAFGBkRJDaAYSG6AC4X4VKH0wXoGnC5jIlcv1PNC0Q7FZdBjJRGIwCIUDfmr9EyzAAAAABJRU5ErkJggg==");
my $pngOffline = decode_base64("iVBORw0KGgoAAAANSUhEUgAAAAQAAAAEEAYAAAD5YUI9AAAABmJLR0T///////8JWPfcAAAACXBIWXMAAABIAAAASABGyWs+AAAAF0lEQVQI12NggIL//xEkCh+nBDog2wQAOLwf4aFzXgQAAAAASUVORK5CYII=");

sub getHttpData {
	my ($uri) = @_;
	my ($req, $res);
	$req = HTTP::Request->new(GET => $uri);
#	$req->header('Accept' => 'image/png');
	$res = $ua->request($req);
	return ($res->code, $res->content);
}

sub isValidPath {
	my ($filename) = @_;
	return 0 if (! defined $filename);
	return 1 if ($filename =~ m/^\/data\/(raster\/)?[0-9.]+[a-z]*\/new\/[0-9]+\/[0-9]+-[0-9]+-img\.png$/);
	return 0;
}

# make dummy image data
sub responseDummyImage {
	my ($img) = @_;
	my $pngsize = length($img);
		print "Status: 200 replacement image\n";
		print "Content-type: image/png\n";
		print "Content-Length: $pngsize\n";
		print "\n";
		print $img;
}

sub isPng {
	my ($data) = @_;
	return 1 if ($data =~ m/^\x89PNG/);
	return 0;
}

sub responseRequest {
	my ($path) = @_;
	if (! isValidPath($path)) {
		print "Status: 403 filename invalid\n";
		print "Content-type: text/plain\n";
		print "\n";
		print "filename invalid\n";
		return;
	}
	my $data = $cache->get($path);
	if (defined $data) {
		my $pngsize = length($data);
		print "Status: 200 cached\n";
		print "Content-type: image/png\n";
		print "Content-Length: $pngsize\n";
		print "\n";
		print $data;
		return;
	}
	if ($isOfflineMode) {
		responseDummyImage($pngOffline);
		return;
	}
	my ($status, $body) = getHttpData("http://cyberjapandata.gsi.go.jp$path");
	if ($status != 200 || length($body) == 0 || ! isPng($body)) {
		responseDummyImage($pngBroken);
		return;
	}
	my $pngsize = length($body);
	print "Status: 200 ok\n";
	print "Content-type: image/png\n";
	print "Content-Length: $pngsize\n";
	print "\n";
	print $body;
	$cache->set($path, $body);
	return;
}

# main logic starts here

my $path = $query->param('filename');
responseRequest($path);
close(STDOUT);							# close the connection from google Earth
$cache->Purge if (rand(1) < 0.05);		# execute the Purge probability of 5%
exit 0;

ということで、就活行ってきます。えぇ、お仕事募集中ですよ。もちろん。