charset.plp

   1 <:
   2 use utf8;
   3 use strict;
   4 use warnings;
   5 use open IO => ':utf8';
   6
   7 our $VERSION = 'v1.0';
   8
   9 $header{content_type} = 'text/html; charset=utf-8';
  10
  11 :><!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
  12  "http://www.w3.org/TR/html4/loose.dtd">
  13 <html>
  14
  15 <head>
  16 <meta http-equiv="content-type" content="<:= $header{content_type} :>">
  17 <title>charset cheat sheet</title>
  18 <link rel="stylesheet" type="text/css" media="all" href="/base.css">
  19 </head>
  20
  21 <body id="charset">
  22 <h1>Character encoding</h1>
  23
  24 <:
  25 my $diinfo = do 'digraphs.inc.pl';
  26 my %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} }
  27         keys %$diinfo;
  28
  29 use Encode qw(decode resolve_alias);
  30 # generate character table(s)
  31 # (~16x faster than decoding in loop;
  32 #  substr strings is twice as fast as splitting to an array)
  33 my %ALIAS = (
  34 #       default => [qw(unicode utf-8 iso-8859-1 cp437 -cp1252- --iso-8859-15- -koi8-f)],
  35         default => [qw(unicode- utf-8 iso-8859-1 -cp1252- --iso-8859-15- cp437 -cp850)],
  36         0 => [qw(cp437 cp863)],
  37         1 => [qw(iso-8859-1 cp1252 MacRoman cp850)],
  38         2 => [qw(iso-8859-2 cp1250 cp852 MacCentralEurRoman MacCroatian MacRumanian)],
  39         5 => [qw(koi8-f iso-8859-5 cp1251 MacCyrillic cp855 cp866)],
  40         7 => [qw(iso-8859-7 cp1253 MacGreek cp737 cp869)],
  41         8 => [qw(iso-8859-8 cp1255 MacHebrew cp862)],
  42 );
  43 my @request = map {
  44         if (my $input = $_) {
  45                 my %row = (offset => 0);
  46                 my $endpoint = 255;
  47                 if ($input =~ s/^--//) {
  48                         $row{offset} = $endpoint > 160 ? 160 : 48;
  49                 }
  50                 elsif ($input =~ s/^-//) {
  51                         $row{offset} = $endpoint > 128 ? 128 : 32;
  52                 }
  53                 if ($input =~ s/-$//) {
  54                         $endpoint = $row{offset} ? $row{offset} < 160 ? 159 : 191 : 127;
  55                 }
  56
  57                 if ($input =~ /^U([0-9a-f]+)(?:-([0-9a-f]+))?/) {
  58                         my $start = hex($1) << ($2 ? 4 : 8);
  59                         my $end = $2 ? hex($2) << 4 : $start + 240;
  60                         $row{table} = join '', map { chr } $start .. $end+15;
  61                         utf8::upgrade($row{table});  # prevent latin1 output
  62                         $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
  63                 }
  64                 elsif ($input eq 'U') {
  65                         $row{table} = ' ' x 512;
  66                         $row{set} = 'Unicode planes';
  67                         $row{cell} = do 'charset-ucplanes.inc.pl';
  68                 }
  69                 elsif ($row{set} = resolve_alias($input)) {
  70                         if ($row{set} eq 'Internal') {
  71                                 $row{table} = ' ' x ($endpoint < 255 ? 640 : 4096);
  72                                 $row{set} = 'Unicode BMP';
  73                                 $row{cell} = do 'charset-unicode.inc.pl';
  74                         }
  75                         elsif ($row{set} eq 'utf-8-strict') {
  76                                 $row{table} = undef;
  77                                 $row{set} = 'UTF-8';
  78                                 $row{cell} = do 'charset-utf8.inc.pl';
  79                         }
  80                         else {
  81                                 $row{table} = decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
  82                         }
  83                 }
  84                 else {
  85                         print "<p>Encoding $input unknown</p>\n";
  86                 }
  87                 \%row;
  88         }
  89         else {
  90                 ();
  91         }
  92 } map { defined $ALIAS{$_} ? @{ $ALIAS{$_} } : $_ }
  93         $ENV{PATH_INFO} =~ /\w/ ? split(m{[/+\s]}, $ENV{PATH_INFO}) : 'default';
  94 my $NOCHAR = chr 0xFFFD;
  95
  96 for my $cp437 (grep {$request[$_]->{set} eq 'cp437'} 0 .. $#request) {
  97         substr($request[$cp437]->{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
  98         substr($request[$cp437]->{table}, 0, 32) = pack 'U*', map {hex} qw(
  99                 2007 263A 263B 2665 2666 2663 2660 2022 25D8 25CB 25D9 2642 2640 266A 266B 263C
 100                 25BA 25C4 2195 203C 00B6 00A7 25AC 21A8 2191 2193 2192 2190 221F 2194 25B2 25BC
 101         );
 102 }
 103
 104 sub quote {
 105         local $_ = shift;
 106         s/"/&quot;/g;
 107         s/</&lt;/g;
 108         s/>/&gt;/g;
 109         return $_;
 110 }
 111
 112 my @nibble = (0..9, 'A'..'F');
 113 for my $row (@request) {
 114         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 115         printf '<caption>%s</caption>', $row->{set};
 116         print '<col>' x 17;
 117         for my $section (qw{thead}) {
 118                 print "<$section><tr><th>↱";
 119                 print '<th>', $_ for @nibble;
 120                 print "\n";
 121         }
 122         print '<tbody>';
 123         for my $msb (0 .. (length($row->{table}) || 256) - 1 >> 4) {
 124                 printf '<tr><th>%X', $msb + ($row->{offset} >> 4);
 125                 for my $lsb (0 .. $#nibble) {
 126                         if ($row->{cell}) {
 127                                 print $row->{cell}->(($msb<<4) + $lsb);
 128                                 next;
 129                         }
 130
 131                         my $glyph = substr $row->{table}, ($msb<<4) + $lsb, 1;
 132                         if ($glyph eq $NOCHAR) {
 133                                 print '<td>';
 134                                 next;
 135                         }
 136
 137                         my $info = [ord $glyph];
 138                         if (defined (my $mnem = $di{ord $glyph})) {
 139                                 $info = $diinfo->{$mnem};
 140                         }
 141                         else {
 142                                 require Unicode::UCD;
 143                                 my $fullinfo = Unicode::UCD::charinfo(ord $glyph);
 144                                 $info = [@$fullinfo{qw/code name category script string/}] if $fullinfo;
 145                         }
 146                         my ($codepoint, $name, $prop, $script, $string) = @$info;
 147
 148                         $glyph = quote($string || $glyph);
 149                         my $desc = sprintf 'U+%04X%s', $codepoint, $name && " ($name)";
 150                         my @class = ('X', grep {$_} $prop, $script);
 151
 152                         $glyph = "<span>$glyph</span>" if $prop eq 'Zs';
 153
 154                         printf "\n".'<td class="%s" title="%s">%s',
 155                                 join(' ', @class), quote($desc), $glyph;
 156                 }
 157                 print "\n";
 158         }
 159         print "</table></div>\n";
 160 }
 161
 162 :>
 163 <hr>
 164
 165 <div class="legend">
 166         <table class="glyphs"><tr>
 167         <td class="X Cc">control
 168         <td class="X Zs"><span>whitespace</span>
 169         <td class="X Mn">diacritic<table class="glyphs"><tr>
 170                 <td class="X Sk">letter
 171                 </table>
 172         <td class="X Po">punctuation<table class="glyphs"><tr>
 173                 <td class="X Pf">quote
 174                 </table>
 175         <td class="X So">symbol<table class="glyphs"><tr>
 176                 <td class="X Sm">math
 177                 <td class="X Sc">currency
 178                 </table>
 179         <td class="X No">numeric
 180         <td class="X Greek">greek<table class="glyphs"><tr>
 181                 <td class="X Latin">latin
 182                 <td class="X Cyrillic">cyrillic
 183                 </table>
 184         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 185                 <td class="X Brahmic">brahmic
 186                 <td class="X Arabic">arabic
 187                 </table>
 188         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 189                 <td class="X African">african
 190                 <td class="X Hiragana">japanese
 191                 <td class="X Han">cjk
 192                 <td class="X Bopomofo">chinese
 193                 </table>
 194         <td class="X Alpha">alphabetic
 195         </table>
 196
 197         <table class="glyphs"><tr>
 198         <td class="X">unicode 5.0
 199         <td class="X Xr">proposed
 200         <td class="X Xd">deprecated
 201         <td class="">unassigned
 202         <td class="X Xi">invalid
 203         </table>
 204 </div>
 205
 206 <p class="footer">
 207         <a href="/" rel="home">sheet.shiar.nl</a>/charset.<a href="/source/charset.plp"
 208          rel="code" title="Written in Perl">plp</a>
 209         <a href="http://git.shiar.nl/sheet.git/history/HEAD:/charset.plp"
 210          rel="vcs-git" title="Git repository"><:= $VERSION :></a>
 211         created by <a href="http://shiar.nl/" rel="author">Shiar</a> •
 212         <a href="http://www.fsf.org/licensing/licenses/agpl-3.0.html" rel="copyright"
 213          title="Licensed under the GNU Affero General Public License, version 3">AGPLv3</a>
 214 </p>
 215
 216 </html>