charset.plp

   1 <:
   2 use utf8;
   3 use strict;
   4 use warnings;
   5 use open IO => ':utf8';
   6
   7 our $VERSION = '1.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 <title>charset cheat sheet</title>
  17 <meta http-equiv="content-type" content="utf-8">
  18 <link rel="stylesheet" type="text/css" media="all" href="/base.css">
  19 </head>
  20
  21 <body>
  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(utf-8 iso-8859-1 cp437)],
  35         0 => [qw(cp437 cp863)],
  36         1 => [qw(iso-8859-1 cp1252 MacRoman cp850)],
  37         2 => [qw(iso-8859-2 cp1250 cp852 MacCentralEurRoman MacCroatian MacRumanian)],
  38         5 => [qw(koi8-f iso-8859-5 cp1251 MacCyrillic cp855 cp866)],
  39         7 => [qw(iso-8859-7 cp1253 MacGreek cp737 cp869)],
  40         8 => [qw(iso-8859-8 cp1255 MacHebrew cp862)],
  41 );
  42 my @request = grep { defined } map {
  43         $_ ? (resolve_alias($_) or print("Encoding $_ unknown") && ()) : ();
  44 } map { defined $ALIAS{$_} ? @{ $ALIAS{$_} } : $_ }
  45         $ENV{PATH_INFO} =~ /\w/ ? split(m{[/+\s]}, $ENV{PATH_INFO}) : 'default';
  46 my @tables = map { $_ eq 'utf-8-strict' ? undef : decode($_, pack 'C*', 0..255) } @request;
  47 my $NOCHAR = chr 0xFFFD;
  48
  49 for my $cp437 (grep {$request[$_] eq 'cp437'} 0 .. $#request) {
  50         substr($tables[$cp437], 237, 1) = pack 'U*', 0x3D5; # phi sign
  51         substr($tables[$cp437], 0, 32) = pack 'U*', map {hex} qw(
  52                 2007 263A 263B 2665 2666 2663 2660 2022 25D8 25CB 25D9 2642 2640 266A 266B 263C
  53                 25BA 25C4 2195 203C 00B6 00A7 25AC 21A8 2191 2193 2192 2190 221F 2194 25B2 25BC
  54         );
  55 }
  56
  57 sub quote {
  58         local $_ = shift;
  59         s/"/&quot;/g;
  60         s/</&lt;/g;
  61         s/>/&gt;/g;
  62         return $_;
  63 }
  64
  65 sub printcell_utf8 {
  66         my ($value) = @_;
  67         if ($value <= 0x7F) {
  68                 print '<td rowspan="8" colspan="16" class="X di-a"',
  69                           ' title="U+0000 – U+007F">Single byte ASCII'
  70                         if $value == 0;
  71         }
  72         elsif ($value <= 0xBF) {
  73                 print '<td rowspan="4" colspan="16" class="X di-d"',
  74                           '>Multi-byte continuation'
  75                         if $value == 0x80;
  76         }
  77         elsif ($value <= 0xC1) {
  78                 print '<td colspan="2" class="X di-b" style="border-right:none; border-bottom:none"',
  79                           ' title="U+0000 – U+007F">(Overl.)'
  80                         if $value == 0xC0;
  81         }
  82         elsif ($value <= 0xDF) {
  83                 print '<td rowspan="2" colspan="14" class="X di-prop" style="border-left:none"',
  84                           ' title="U+0080 – U+03FF">2-byte sequence start'
  85                         if $value == 0xC2;
  86                 print '<td rowspan="1" colspan="16" class="X di-prop" style="border-top:none"',
  87                           ' title="U+0400 – U+07FF">'
  88                         if $value == 0xD0;
  89         }
  90         elsif ($value <= 0xEF) {
  91                 print '<td colspan="16" class="X di-prop"',
  92                           ' title="U+0800 – U+FFFF">3-byte sequence start'
  93                         if $value == 0xE0;
  94         }
  95         elsif ($value <= 0xF4) {
  96                 print '<td colspan="5" class="X di-prop" style="border-right:none"',
  97                           ' title="U+1·0000 – U+10·FFFF">4-byte sequence'
  98                         if $value == 0xF0;
  99         }
 100         elsif ($value <= 0xF7) {
 101                 print '<td colspan="3" class="X di-b" style="border-left:none"',
 102                           ' title="U+11·0000 – U+1FF·FFFF">(Overflow)'
 103                         if $value == 0xF5;
 104         }
 105         elsif ($value <= 0xFB) {
 106                 print '<td colspan="4" class="X di-b"',
 107                           ' title="U+200·0000 – U+3FFF·FFFF">5-byte'
 108                         if $value == 0xF8;
 109         }
 110         elsif ($value <= 0xFD) {
 111                 print '<td colspan="2" class="X di-b"',
 112                           ' title="U+4000·0000 – 7FFFF·FFFF">6-byte'
 113                         if $value == 0xFC;
 114         }
 115         elsif ($value <= 0xFF) {
 116                 print '<td colspan="2" class="di-invalid">Invalid'
 117                         if $value == 0xFE;
 118         }
 119         else {
 120                 print "\n".'<td class="X">?';
 121         }
 122 }
 123
 124 print "<ul>\n";
 125
 126 my @nibble = (0..9, 'A'..'F');
 127 for my $tablenum (0 .. $#tables) {
 128         print '<li><table class="glyphs">';
 129         printf '<caption>%s</caption>', $request[$tablenum] eq 'utf-8-strict' ? 'UTF-8' : $request[$tablenum];
 130         print '<col>';
 131         for my $section (qw{thead}) {
 132                 print "<$section><tr><th>↱";
 133                 print '<th>', $_ for @nibble;
 134                 print "\n";
 135         }
 136         print '<tbody>';
 137         for my $msb (0 .. $#nibble) {
 138                 print '<tr><th>', $nibble[$msb];
 139                 for my $lsb (0 .. $#nibble) {
 140                         if ($request[$tablenum] eq 'utf-8-strict') {
 141                                 printcell_utf8(($msb<<4) + $lsb);
 142                                 next;
 143                         }
 144
 145                         my $glyph = substr $tables[$tablenum], ($msb<<4) + $lsb, 1;
 146                         if ($glyph eq $NOCHAR) {
 147                                 print '<td>';
 148                                 next;
 149                         }
 150                         my $info = [ord $glyph];
 151                         if (defined (my $mnem = $di{ord $glyph})) {
 152                                 $info = $diinfo->{$mnem};
 153                         }
 154                         my ($codepoint, $name, $prop, $script, $string) = @$info;
 155
 156                         $glyph = quote($string || $glyph);
 157                         my $desc = sprintf 'U+%04X%s', $codepoint, $name && " ($name)";
 158                         my @class = ('X', grep {$_} $prop, $script);
 159
 160                         $glyph = "<span>$glyph</span>" if $prop eq 'Zs';
 161
 162                         printf "\n".'<td class="%s" title="%s">%s',
 163                                 join(' ', @class), quote($desc), $glyph;
 164                 }
 165                 print "\n";
 166         }
 167         print "</table>\n";
 168 }
 169
 170 print "</ul>\n";
 171
 172 :>
 173 <hr>
 174
 175 <p class="footer">
 176         <a href="http://sheet.shiar.nl/" rel="home">sheet.shiar.nl</a>/charset
 177         <a href="git://git.shiar.nl/sheet" rel="vcs-git" title="Git repository"><:= "v$VERSION" :></a>
 178         created by <a href="http://shiar.nl/" rel="author">Shiar</a> •
 179         <a title="Licensed under the GNU Affero General Public License, version 3" rel="copyright"
 180            href="http://www.fsf.org/licensing/licenses/agpl-3.0.html">AGPLv3</a> •
 181         last update <:
 182                 use Time::Format qw(time_format);
 183                 print time_format('yyyy-mm-dd', (stat $ENV{SCRIPT_FILENAME})[9]);
 184         :>
 185 </p>
 186
 187 </html>