charset.plp

   1 <(common.inc.plp)><:
   2
   3 Html({
   4         title => 'charset cheat sheet',
   5         version => '1.0',
   6         description => [
   7                 "Reference sheet with all glyphs in common character encoding tables,",
   8                 "and an overview of Unicode ranges and UTF-8 bytes.",
   9         ],
  10         keywords => [qw'
  11                 charset codepage unicode ascii utf8 latin glyph character encoding
  12                 reference common overview table
  13         '],
  14         stylesheet => [qw'light'],
  15         data => [qw'charset-unicode.inc.pl charset-utf8.inc.pl'],
  16 });
  17
  18 my @tablist = split /[^\w-]+/, $Request || 'default';
  19
  20 :>
  21 <h1>Character encoding</h1>
  22
  23 <:
  24 use POSIX qw( ceil );
  25 use Shiar_Sheet::FormatChar;
  26 my $glyphs = Shiar_Sheet::FormatChar->new;
  27 my @request;
  28
  29 sub tabinput {
  30         # generate character table(s)
  31         my $input = shift or return;
  32
  33         state $ALIAS = {
  34                 default    => [qw( unicode+0-192 utf-8 iso-8859-1 iso-8859-15 cp1252 cp437 cp850 )],
  35                 us         => [qw( cp437 cp863 AdobeStandardEncoding gsm0338 )],
  36                 ebcdic     => [qw( cp37 cp500 cp875 cp1026 cp1047 posix-bc )],
  37                 iso        => [map {"iso-8859-$_"} 1 .. 11, 13 .. 16],
  38                 dos        => [qw( cp437 cp863 cp850 cp860 cp852 cp855 cp866 cp864 cp1006 cp737 cp869 cp862 cp862 cp857 cp865 cp861 cp874 cp775 )],
  39
  40                 westeur    => [qw( iso-8859-1 iso-8859-15 cp1252 iso-8859-14 cp850 hp-roman8 nextstep MacRoman )],
  41                 centeur    => [qw( iso-8859-2 iso-8859-16 cp1250 cp852 MacRomanian MacCroatian MacCentralEurRoman )], # MacRumanian only for DB
  42                 turkish    => [qw( iso-8859-9 iso-8859-3 cp1254 cp857 MacTurkish )],
  43                 baltic     => [qw( iso-8859-4 iso-8859-13 cp1257 cp775 )],
  44                 nordic     => [qw( iso-8859-10 cp865 cp861 MacIcelandic MacSami )],
  45                 cyrillic   => [qw( koi8-f koi8-r koi8-u iso-8859-5 cp1251 MacCyrillic cp855 cp866 )], # MacUkrainian is broken
  46                 arabic     => [qw( iso-8859-6 cp1006 cp864 cp1256 MacArabic )], # MacFarsi same as MacArabic?
  47                 greek      => [qw( iso-8859-7 cp1253 MacGreek cp737 cp869 )],
  48                 hebrew     => [qw( iso-8859-8 cp1255 MacHebrew cp862 )],
  49                 thai       => [qw( iso-8859-11 cp874 MacThai )],
  50                 vietnamese => [qw( viscii cp1258 MacVietnamese )],
  51                 symbol     => [qw( symbol dingbats MacDingbats AdobeZdingbat AdobeSymbol )],
  52                 # iso-code shorthand
  53                 1 => 'westeur',
  54                 2 => 'centeur',
  55                 3 => 'turkish',
  56                 4 => 'baltic',
  57                 5 => 'cyrillic',
  58                 6 => 'arabic',
  59                 7 => 'greek',
  60                 8 => 'hebrew',
  61                 9 => 'turkish',
  62                 10 => 'nordic',
  63                 11 => 'thai',
  64         };
  65         if (my $follow = $ALIAS->{$input}) {
  66                 tabinput($_) for ref $follow ? @{$follow} : $follow;
  67                 return;
  68         }
  69
  70         state $visible = {};  # all present tables
  71         my %row = (offset => 0, cols => 16);
  72         my $endpoint = 255;
  73         my $params = $input =~ s/[+](.*)\z// ? $1 : undef;
  74
  75         if (not defined $params) {
  76                 use List::Util qw( first pairfirst pairs );
  77
  78                 state $INHERIT = {
  79                         'cp437'       => ['cp850' => 0], # ascii range overridden later
  80                         'gsm0338'     => ['ascii' => '0-127'],
  81
  82                         'iso-8859-2'  => ['iso-8859-1' => '160'],
  83                         'iso-8859-3'  => ['iso-8859-1' => '160'],
  84                         'iso-8859-4'  => ['iso-8859-2' => '160'],
  85                         'iso-8859-5'  => ['iso-8859-1' => '160'],
  86                         'iso-8859-6'  => ['iso-8859-1' => '160'],
  87                         'iso-8859-7'  => ['iso-8859-1' => '160'],
  88                         'iso-8859-8'  => ['iso-8859-1' => '160'],
  89                         'iso-8859-9'  => ['iso-8859-1' => '208'],
  90                         'iso-8859-10' => ['iso-8859-4' => '160'],
  91                         'iso-8859-11' => ['iso-8859-1' => '160'],
  92                         'iso-8859-13' => ['iso-8859-4' => '160'],
  93                         'iso-8859-14' => ['iso-8859-1' => '160'],
  94                         'iso-8859-15' => ['iso-8859-1' => '160-191'],
  95                         'iso-8859-16' => ['iso-8859-2' => '160'],
  96
  97                         'cp1252'      => ['iso-8859-1' => '128-159'],
  98                         'cp1250'      => ['iso-8859-2' => '128-191'],
  99                         'cp1254'      => ['iso-8859-9' => '128-159'],
 100                         'cp1257'      => ['iso-8859-13' => '128-'],
 101
 102                         'cp850'       => ['cp437' => '144'],
 103                         'cp865'       => ['cp437' => '144-176'],
 104                         'cp852'       => ['cp850' => '128', 'cp437' => '128'],
 105                         'cp857'       => ['cp850' => '128-239', 'cp437' => '128'],
 106                         'cp775'       => ['cp850' => '128'],  # partial cp437
 107
 108                         'MacRomanian' => ['MacRoman' => '160'],
 109                         'MacCroatian' => ['MacRoman' => '160'],
 110                         'MacCentralEurRoman' => ['MacRoman' => '128'],
 111                         'MacTurkish'  => ['MacRoman' => '208-223'], # F5 is unassigned
 112                 };
 113
 114                 my @parents = @{ $INHERIT->{$input} || [] };
 115
 116                 if (my ($parent, $part) = pairfirst { $visible->{$a} } @parents) {
 117                         $row{parent} = $parent;
 118                         $params = $part;
 119                 }
 120                 elsif ($visible->{ascii}) {
 121                         $row{parent} = $parents[0] || 'ascii';
 122                         $params = $parents[1] || 128;
 123                         $params = 128 if $params >= 128;  # ascii offset at most
 124                 }
 125                 elsif (@parents) {
 126                         $row{parent} = $parents[0];
 127                 }
 128         }
 129
 130         if (defined $params and $params =~ m/^ (\d+) (-\d+)? /x) {
 131                 $row{offset} = $1;
 132                 $endpoint = -$2 if $2;
 133         }
 134
 135         if ($input =~ /^U([0-9a-f]+)(?:-([0-9a-f]+))?/) {
 136                 my $start = hex($1) << ($2 ? 4 : 8);
 137                 my $end = $2 ? hex($2) << 4 : $start + 240;
 138                 $row{table} = join '', map { chr } $start .. $end+15;
 139                 utf8::upgrade($row{table});  # prevent latin1 output
 140                 $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
 141         }
 142         elsif ($input eq 'U') {
 143                 $row{table} = ' ' x 1024;
 144                 $row{set} = 'Unicode planes';
 145                 $row{cell} = do 'charset-ucplanes.inc.pl'
 146                         or Alert('Table data could not be read', $@ || $!);
 147                 $row{cols} *= 2;
 148         }
 149         elsif ($row{set} = Encode::resolve_alias($input)) {
 150                 if ($row{set} eq 'Internal') {
 151                         $row{table} = ' ' x ($endpoint < 255 ? 640 : 8192);
 152                         $row{set} = 'Unicode BMP';
 153                         $row{cell} = do 'charset-unicode.inc.pl'
 154                                 or Alert('Table data could not be read', $@ || $!);
 155                 }
 156                 elsif ($row{set} eq 'utf-8-strict') {
 157                         $row{table} = undef;
 158                         $row{set} = 'UTF-8';
 159                         $row{cell} = do 'charset-utf8.inc.pl'
 160                                 or Alert('Table data could not be read', $@ || $!);
 161                 }
 162                 else {
 163                         $row{table} = Encode::decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
 164                                 # (~16x faster than decoding in loop;
 165                                 #  substr strings is twice as fast as splitting to an array)
 166
 167                         if ($row{set} eq 'cp437' and !$row{offset}) {
 168                                 substr($row{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
 169                                 substr($row{table}, 0, 32) = pack 'U*', map {hex} qw(
 170                                         2007 263A 263B 2665 2666 2663 2660 2022
 171                                         25D8 25CB 25D9 2642 2640 266A 266B 263C
 172                                         25BA 25C4 2195 203C 00B6 00A7 25AC 21A8
 173                                         2191 2193 2192 2190 221F 2194 25B2 25BC
 174                                 );
 175                         }
 176
 177                         $visible->{ascii} =  # assume common base
 178                         $visible->{ $row{set} } = 1;
 179                 }
 180         }
 181         else {
 182                 Alert("Encoding <q>$input</q> unknown");
 183                 return;
 184         }
 185         push @request, \%row;
 186 }
 187 tabinput($_) for @tablist;
 188
 189 my $NOCHAR = chr 0xFFFD;
 190
 191 sub range_cell {
 192         my ($info, $offset) = @_;
 193         my $table = $info->{cell} or return;
 194         my $def = $table->{$offset} or return;
 195         my ($len, $class, $name, $title) = @{$def};
 196
 197         my $cols = $info->{cols};
 198         my $colsize = $table->{colsize} || 1;
 199         my $attr = '';
 200         $len /= $colsize;
 201         $name //= $len <= 2 ? 'res' : 'reserved';
 202
 203         if (my $part = $offset/$colsize % $cols) {
 204                 # continued row
 205                 my $rest = $cols - $part;  # remaining
 206                 $rest = $len if $len < $rest; #TODO: optimise
 207                 if ($len -= $rest) {
 208                         # continued on new row
 209                         my @next = ($len * $colsize, "$class joinu");
 210                         if ($len > $rest) {
 211                                 # minority remains
 212                                 push @next, $name, $title;
 213                                 $title ||= $name;
 214                                 $name = '';
 215                         }
 216                         else {
 217                                 # minority on next row
 218                                 push @next, '"', $title || $name;
 219                         }
 220                         $table->{$offset + $colsize*$rest} //= \@next;
 221                         $class .= ' joind';
 222                 }
 223                 $len = $rest;
 224         }
 225         elsif (my $rows = int($len / $cols)) {
 226                 # multiple full rows
 227                 if ($len -= $rows * $cols) {
 228                         # partial row remains
 229                         $table->{$offset + $colsize*$rows * $cols} //= [$len*$colsize, "$class joinu", '', $title];
 230                         $class .= ' joind';
 231                 }
 232                 $attr .= sprintf ' rowspan=%d', $rows;
 233                 $len = $cols;
 234         }
 235
 236         $attr .= sprintf ' colspan=%d', $len unless $len == 1;
 237         $attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
 238         $attr .= sprintf ' class="%s"', $class if $class;
 239         $attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
 240         return "<td$attr>$name";
 241 }
 242
 243 for my $row (@request) {
 244         my $cols = $row->{cols};
 245         my $colsize = $row->{cell} && $row->{cell}->{colsize} || 1;
 246         my $coldigits = ceil(log($colsize * $cols) / log(16));  # uniform length of hexadecimal header
 247         my $rowdiv = 16 ** $coldigits;  # row divide for column digits
 248         $rowdiv = 1 if $rowdiv != $cols * $colsize;  # divide only if all columns are matched
 249         my $offset = 0;
 250         my $endpoint = $offset + (length($row->{table}) || 256) * $colsize;
 251
 252         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 253         my $title = $row->{set};
 254         $title .= " <aside>(over $_)</aside>"
 255                 for grep { $_ ne 'iso-8859-1' } $row->{parent} // ();
 256         printf '<caption>%s</caption>', $title;
 257         print '<col>' x ($cols + 1);
 258         for my $section (qw{thead}) {
 259                 print "<$section><tr><th>", $rowdiv == 1 ? '+' : '↱';
 260                 printf '<th>%0*X', $coldigits, $_ * $colsize for 0 .. $cols - 1;
 261                 print "\n";
 262         }
 263         print '<tbody>';
 264         while ($offset < $endpoint - 1) {
 265                 print '<tr><th>';
 266                 {
 267                         if (my $rowmod = $offset % $rowdiv) {
 268                                 # offset in column units
 269                                 printf '<small>+%X</small>', $rowmod;
 270                         }
 271                         else {
 272                                 # divided row offset
 273                                 printf '%X', ($offset + $row->{offset}) / $rowdiv;
 274                         }
 275                 }
 276                 for (1 .. $cols) {
 277                         if ($row->{cell}) {
 278                                 print range_cell($row, $offset);
 279                                 next;
 280                         }
 281
 282                         my $glyph = substr $row->{table}, $offset, 1;
 283                         if ($glyph eq $NOCHAR) {
 284                                 print '<td>';
 285                                 next;
 286                         }
 287
 288                         print "\n".$glyphs->glyph_cell($glyph);
 289                 }
 290                 continue {
 291                         $offset += $colsize;
 292                 }
 293                 print "\n";
 294         }
 295         say '</table></div>';
 296 }
 297
 298 :>
 299 <hr>
 300
 301 <div class="legend">
 302         <table class="glyphs"><tr>
 303         <td class="X Cc">control
 304         <td class="X Zs"><span>whitespace</span>
 305         <td class="X Mn">diacritic<table class="glyphs"><tr>
 306                 <td class="X Sk">letter
 307                 </table>
 308         <td class="X Po">punctuation<table class="glyphs"><tr>
 309                 <td class="X Pf">quote
 310                 </table>
 311         <td class="X So">symbol<table class="glyphs"><tr>
 312                 <td class="X Sm">math
 313                 <td class="X Sc">currency
 314                 </table>
 315         <td class="X No">numeric
 316         <td class="X Greek">greek<table class="glyphs"><tr>
 317                 <td class="X Latin">latin
 318                 <td class="X Cyrillic">cyrillic
 319                 </table>
 320         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 321                 <td class="X Brahmic">brahmic
 322                 <td class="X Arabic">arabic
 323                 </table>
 324         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 325                 <td class="X African">african
 326                 <td class="X Hiragana">japanese
 327                 <td class="X Han">cjk
 328                 <td class="X Bopomofo">chinese
 329                 </table>
 330         <td class="X Alpha">alphabetic
 331         </table>
 332
 333         <table class="glyphs"><tr>
 334         <td class="X">unicode 7.0
 335         <td class="X Xr">proposed
 336         <td class="X Xd">deprecated
 337         <td class="">unassigned
 338         <td class="X Xi">invalid
 339         </table>
 340 </div>
 341