#!/usr/local/bin/perl -w

use strict;

use subs "main";
use subs "not_supported uri";
use subs "not_registed uri";
use subs "urn_ietf uri";
use subs "urn_issn uri";
use subs "urn_isbn uri";

# sub routine
use subs "urn_ietf_check_draft id";
use subs "urn_ietf_check_std id rfc";
use subs "urn_ietf_check_fyi id rfc";
use subs "error_out error_j error_e uri";

exit main;

sub main {
	my $uri = $ENV{QUERY_STRING};
	$uri =~ s/%([a-f\d]{2})/chr hex $1/gei;
	if ($uri !~ /^urn:/i) {
		not_supported($uri);
	}
	
	# Namespace ID switch
	SWITCH: for ((split ':', $uri)[1]) {
		/^ietf$/i && do {
				urn_ietf($uri);
				last SWITCH;
			};
		/^issn$/i && do {
				urn_issn($uri);
				last SWITCH;
			};
		/^isbn$/i && do {
				urn_isbn($uri);
				last SWITCH;
			};
		not_supported($uri);
	}
	
	0;
}

sub urn_ietf ($) {
	my $uri = shift;
	not_supported('(null)') unless defined $uri;
	
	my ($urn, $nid, $nss, @param) = split ':', $uri;
	my $param = join ':', @param;
	my $redirect = '';
	IETF_SWITCH: for ($nss) {
		/^rfc$/i && do {
				$param =~ tr/\D//;
				$redirect = 'http://www.ietf.org/rfc/rfc'.(sprintf "%d", $param).".txt";
				last IETF_SWITCH;
			};
		/^std$/i && do {
				$param =~ tr/\D//;
				my $rfc;
				if (urn_ietf_check_std($param, \$rfc)) {
					$redirect = "http://www.ietf.org/rfc/rfc$rfc.txt";
				} else {
					not_registed($uri);
					return;
				}
				last IETF_SWITCH;
			};
		/^fyi$/i && do {
				$param =~ tr/\D//;
				my $rfc;
				if (urn_ietf_check_fyi($param, \$rfc)) {
					$redirect = "http://www.ietf.org/rfc/rfc$rfc.txt";
				} else {
					not_registed($uri);
					return;
				}
				last IETF_SWITCH;
			};
		/^id$/i && do {
				$param =~ tr/^[\w\d\-]//;
				if (urn_ietf_check_draft($param)) {
					$redirect = "http://www.ietf.org/internet-drafts/draft-$param.txt";
				} else {
					not_registed($uri);
					return;
				}
				last IETF_SWITCH;
			};
		$redirect = '';
	}
	if ($redirect ne '') {
		print "Location: $redirect\n\n";
	} else {
		not_supported($uri);
	}
	
	0;
}

sub urn_ietf_check_std ($\$) {
	my ($std, $rfc) = @_;
	
	$$rfc = 0;
	if (open STDLIST, "urn-ietf-std.dat") {
		flock STDLIST, 1;
		while (<STDLIST>) {
			chomp;
			my ($std_item, $rfc_item) = split '\t';
			if ($std_item == $std) {
				$$rfc = sprintf "%d", $rfc_item;
				last;
			}
		}
		flock STDLIST, 8;
		close STDLIST;
	}
	
	$$rfc;
}

sub urn_ietf_check_fyi ($\$) {
	my ($fyi, $rfc) = @_;
	
	$$rfc = 0;
	if (open FYILIST, "urn-ietf-fyi.dat") {
		flock FYILIST, 1;
		while (<FYILIST>) {
			chomp;
			my ($fyi_item, $rfc_item) = split '\t';
			if ($fyi_item == $fyi) {
				$$rfc = sprintf "%d", $rfc_item;
				last;
			}
		}
		flock FYILIST, 8;
		close FYILIST;
	}
	
	$$rfc;
}

sub urn_ietf_check_draft ($) {
	my $id = shift;
	
	my $found = 0;
	if (open DRAFTLIST, "urn-ietf-drafts.dat") {
		flock DRAFTLIST, 1;
		while (<DRAFTLIST>) {
			chomp;
			if ($id eq $_) {
				$found = 1;
				last;
			}
		}
		flock DRAFTLIST, 8;
		close DRAFTLIST;
	}
	
	$found;
}

sub urn_issn ($) {
	my $uri = shift;
	not_supported('(null)') unless defined $uri;
	
	my ($num) = ((split ':', $uri)[2]) =~ /^(\d{4}\-\d{3}[\dXx])$/;
	not_supported('unsupported format $uri') unless defined $num;
	print "Location: http://urn.issn.org/urn/?issn=".(uc $num)."\n\n";
	
	0;
}

sub urn_isbn ($) {
	my $uri = shift;
	not_supported('(null)') unless defined $uri;
	
	my %servers = (
		ja => 'www.amazon.co.jp',
		'en-uk' => 'www.amazon.co.uk',
		de => 'www.amazon.de',
		fr => 'www.amazon.fr',
		default => 'www.amazon.com'
	);
	
	my $num = join "", ($uri =~ /urn:isbn:(\d)-(\d+)-(\d+)-([x\d])$/i);
	not_supported('unsupported format $uri') unless defined $num;
	$num =~ s/\-//g;
	
	my $lang;
	ISBN_SWITCH: {
		$num =~ /^4/ && do { $lang = 'ja';      last ISBN_SWITCH; };
		$num =~ /^0/ && do { $lang = 'default'; last ISBN_SWITCH; };
		$num =~ /^1/ && do { $lang = 'en-uk';   last ISBN_SWITCH; };
		$num =~ /^2/ && do { $lang = 'fr';      last ISBN_SWITCH; };
		$num =~ /^3/ && do { $lang = 'de';      last ISBN_SWITCH; };
		$lang = 'default';
	}
	
	print "Location: http://$servers{$lang}/exec/obidos/ASIN/$num\n\n";
	
	0;
}

#
# ISBN code support (redirect Amazon.co.jp)
#

sub not_supported ($) {
	my $uri = shift;
	error_out('サポート', 'supported', $uri);
}

sub not_registed ($) {
	my $uri = shift;
	error_out('登録', 'registed', $uri);
}

sub error_out ($$$) {
	my ($error, $error_e, $uri) = @_;
	print <<HERE;
Content-type: text/html; charset=EUC-JP

<?xml version="1.0" encoding="EUC-JP" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
		"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja">
<head>
	<meta http-equiv="Content-Type" content="text/html; charset=EUC-JP" />
	<meta name="author" content="KONDOU, Kazuhiro" />
	<meta name="description" xml:lang="ja" content="指定された URI は$errorされていません" />
	<meta name="description" xml:lang="en" content="Specified URI is not $error_e" />
	<link rev="made" href="mailto:kazuhiro\@alib.jp" />
	<link rel="stylesheet" title="Standard" href="/standard.css" type="text/css" media="screen" charset="EUC-JP" />
	<link rel="alternate stylesheet" title="Nazo stealth" href="/nazo_stealth.css" type="text/css" media="all" charset="EUC-JP" />
	<link rel="alternate stylesheet" title="Alternative" href="/alternate.css" type="text/css" media="all" charset="EUC-JP" />
	<link rel="alternate stylesheet" title="Check" href="/check.css" type="text/css" media="all" charset="EUC-JP" />
	<link rel="contents" href="/" />
	
	<title>Not $error_e - Ancient library</title>
</head>

<body>

<div class="Header">
	<h1>$errorされていません</h1>
	<hr />
</div>

<div class="Contents">
	<p>指定されたリソース $uri は$errorされていません。</p>
	<p>申し訳ありませんが、<a href="mailto:kazuhiro\@alib.jp" tabindex="1">管理者へ連絡</a>してみて下さい。リソースが存在したら$errorされるかもしれません。</p>
</div>

<div class="Footer">
	<hr />
	<div class="ReturnPath">
		<p><a href="/" accesskey="t" tabindex="3"><img src="/banner.png" alt="to site top" title="main banner" class="Banner" width="200" height="40" /></a></p>
	</div>
	<address>
		<span class="author">Fuji. / KONDOU, Kazuhiro</span>
		<a href="mailto:kazuhiro\@alib.jp" accesskey="m" tabindex="4" title="ご意見、ご感想、間違い指摘その他はこちらまで">kazuhiro\@alib.jp</a>
	</address>
	<p class="LastModfied">Last modified : 2001/ 9/19 21:43:46</p>
</div>
</body>
</html>
HERE
}