1 |
#!/usr/bin/perl |
2 |
use strict; |
3 |
use lib qw[/home/httpd/html/www/markup/html/whatpm |
4 |
/home/wakaba/work/manakai2/lib |
5 |
/home/httpd/html/swe/lib/]; |
6 |
|
7 |
use CGI::Carp qw[fatalsToBrowser]; |
8 |
require Message::CGI::Carp; |
9 |
|
10 |
my $sw4_url = q<http://suika.fam.cx/~wakaba/wiki/sw/>; |
11 |
|
12 |
require Message::CGI::HTTP; |
13 |
require Encode::EUCJPSW; |
14 |
my $cgi = Message::CGI::HTTP->new; |
15 |
$cgi->{decoder}->{'#default'} = sub { |
16 |
return Encode::decode ('euc-jp-sw', $_[1]); |
17 |
}; |
18 |
|
19 |
my $page = $ENV{QUERY_STRING}; |
20 |
if ($page =~ /[&;]/) { |
21 |
$page = $cgi->get_parameter ('mypage') // ''; |
22 |
} else { |
23 |
$page = Encode::decode ('euc-jp-sw', percent_decode_byte ($page)); |
24 |
} |
25 |
|
26 |
my $url = get_page_url ($page); |
27 |
|
28 |
print qq[Status: 301 Moved |
29 |
Location: $url |
30 |
Content-Type: text/html; charset=utf-8 |
31 |
|
32 |
<!DOCTYPE HTML> |
33 |
<html lang=en> |
34 |
<title>301 Moved</title> |
35 |
<h1>Moved</h1> |
36 |
<p>See <a href="@{[htescape ($url)]}">other page</a>.]; |
37 |
exit; |
38 |
|
39 |
sub get_page_url ($) { |
40 |
my $wiki_name = shift; |
41 |
$wiki_name = percent_encode ($wiki_name); |
42 |
$wiki_name =~ s/%2F/+/g; |
43 |
$wiki_name = $sw4_url . 'n/' . $wiki_name; |
44 |
return $wiki_name; |
45 |
} # get_page_url |
46 |
|
47 |
sub percent_encode ($) { |
48 |
my $s = Encode::encode ('utf8', $_[0]); |
49 |
$s =~ s/([^A-Za-z0-9_~-])/sprintf '%%%02X', ord $1/ges; |
50 |
return $s; |
51 |
} # percent_encode |
52 |
|
53 |
sub percent_decode ($) { # input should be a byte string. |
54 |
my $s = shift; |
55 |
$s =~ s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; |
56 |
return Encode::decode ('utf-8', $s); # non-UTF-8 octet converted to \xHH |
57 |
} # percent_decode |
58 |
|
59 |
sub percent_decode_byte ($) { # input should be a byte string. |
60 |
my $s = shift; |
61 |
$s =~ s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; |
62 |
return $s; |
63 |
} # percent_decode_byte |
64 |
|
65 |
sub htescape ($) { |
66 |
my $s = shift; |
67 |
$s =~ s/&/&/g; |
68 |
$s =~ s/</</g; |
69 |
$s =~ s/"/"/g; |
70 |
return $s; |
71 |
} # htescape |