test/charset/perl-encode.cgi

#!/usr/bin/perl
use strict;
use warnings;
use Encode;
use CGI::Carp qw(fatalsToBrowser);

sub htescape ($) {
  my $s = shift;
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  return $s;
} # htescape

sub udecode ($) {
  my $s = shift;
  $s =~ s/\\(u[0-9A-Fa-f]{4}|U[0-9A-Fa-f]{8})/chr hex substr $1, 1/ge;
  return $s;
} # udecode

sub uencode ($) {
  my $s = shift;
  $s =~ s/([^\x20-\x5B\x5D-\x7E])/sprintf '\U%08X', ord $1/ge;
  return $s;
} # uencode

sub bencode ($) {
  my $s = shift;
  $s =~ s/([^\x21-\x5B\x5D-\x7E])/sprintf '\x%02X', ord $1/ge;
  return $s;
} # bencode

my $params = { map { s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; decode 'utf8', $_ } map { split /=/, $_, 2 } split /[&;]/, $ENV{QUERY_STRING} // '' };

my $s = udecode ($params->{s} // '');
my $c = $params->{c} // 'utf8';

my $encoded = encode $c, $s;

binmode STDOUT, ':encoding(utf-8)';
print qq[Content-Type: text/html; charset=utf-8

<!DOCTYPE HTML>
<html lang=en>
<title>Perl Encoder</title>
<link rel=stylesheet href="http://suika.fam.cx/www/style/html/xhtml">
<h1>Perl Encoder</h1>

<form action method=get accept-charset=utf-8>
  <p><label>Input charset: <input type=text name=c value="@{[htescape $c]}"></label>
  <p><label>Input chars: <input type=text name=s value="@{[htescape uencode $s]}"></label>
  <p><button type=submit>OK</button>

  <p><label>Chars: <output>@{[htescape $s]}</output></label>
  <p><label>Bytes: <output>@{[htescape bencode $encoded]}</output></label>
</form>
];
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3			use warnings;
4			use Encode;
5			use CGI::Carp qw(fatalsToBrowser);
6
7			sub htescape ($) {
8			my $s = shift;
9			$s =~ s/&/&/g;
10			$s =~ s/</</g;
11			$s =~ s/>/>/g;
12			$s =~ s/"/"/g;
13			return $s;
14			} # htescape
15
16			sub udecode ($) {
17			my $s = shift;
18			$s =~ s/\\(u[0-9A-Fa-f]{4}\|U[0-9A-Fa-f]{8})/chr hex substr $1, 1/ge;
19			return $s;
20			} # udecode
21
22			sub uencode ($) {
23			my $s = shift;
24			$s =~ s/([^\x20-\x5B\x5D-\x7E])/sprintf '\U%08X', ord $1/ge;
25			return $s;
26			} # uencode
27
28			sub bencode ($) {
29			my $s = shift;
30			$s =~ s/([^\x21-\x5B\x5D-\x7E])/sprintf '\x%02X', ord $1/ge;
31			return $s;
32			} # bencode
33
34			my $params = { map { s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; decode 'utf8', $_ } map { split /=/, $_, 2 } split /[&;]/, $ENV{QUERY_STRING} // '' };
35
36			my $s = udecode ($params->{s} // '');
37			my $c = $params->{c} // 'utf8';
38
39			my $encoded = encode $c, $s;
40
41			binmode STDOUT, ':encoding(utf-8)';
42			print qq[Content-Type: text/html; charset=utf-8
43
44			<!DOCTYPE HTML>
45			<html lang=en>
46			<title>Perl Encoder</title>
47			<link rel=stylesheet href="http://suika.fam.cx/www/style/html/xhtml">
48			<h1>Perl Encoder</h1>
49
50			<form action method=get accept-charset=utf-8>
51			<p><label>Input charset: <input type=text name=c value="@{[htescape $c]}"></label>
52			<p><label>Input chars: <input type=text name=s value="@{[htescape uencode $s]}"></label>
53			<p><button type=submit>OK</button>
54
55			<p><label>Chars: <output>@{[htescape $s]}</output></label>
56			<p><label>Bytes: <output>@{[htescape bencode $encoded]}</output></label>
57			</form>
58			];