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	#!/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	];