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 m{/+}, $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-639 utf-8 iso-8859-1 iso-8859-15 cp1252 cp437 cp850 )],
  35                 us         => [qw( cp437 cp863 gsm0338 AdobeStandardEncoding )],
  36                 ebcdic     => [qw( cp37 cp500 cp1047 posix-bc cp1026 cp875 )],
  37                 iso        => [map {"iso-8859-$_"} 1 .. 11, 13 .. 16],
  38                 dos        => [qw( cp437 cp865 cp861 cp860 cp863 cp850 cp857 cp852 cp775
  39                                    cp737 cp869 cp866 cp855 cp862 cp864 )],
  40                 aix        => [qw( cp1006 )],
  41                 win        => [qw( cp1252 cp1250 cp1254 cp1257 cp1258 cp1253 cp1251 cp1255 cp1256 cp874 )],
  42                 mac        => [qw( MacRoman MacRomanian MacRumanian MacCroatian MacCentralEurRoman MacTurkish MacIcelandic MacSami
  43                                    MacGreek MacCyrillic MacHebrew MacArabic MacFarsi MacThai )],
  44
  45                 # languages
  46                 westeur    => [qw( iso-8859-1 iso-8859-15 cp1252 iso-8859-14 cp850 hp-roman8 nextstep MacRoman )],
  47                 centeur    => [qw( iso-8859-2 iso-8859-16 cp1250 cp852 MacRomanian MacCroatian MacCentralEurRoman )], # MacRumanian only for DB
  48                 turkish    => [qw( iso-8859-9 iso-8859-3 cp1254 cp857 MacTurkish )],
  49                 baltic     => [qw( iso-8859-4 iso-8859-13 cp1257 cp775 )],
  50                 nordic     => [qw( iso-8859-10 cp865 cp861 MacIcelandic MacSami )],
  51                 cyrillic   => [qw( koi8-r koi8-u koi8-f iso-8859-5 cp1251 MacCyrillic cp866 cp855
  52                                    U4 U2DE-2DF UA64-A69 U50-52 )], # MacUkrainian is broken
  53                 arabic     => [qw( iso-8859-6 cp1256 MacArabic cp864 cp1006 MacFarsi
  54                                    U6 U8A-8F+0-31+64 U75-77 )],
  55                 greek      => [qw( iso-8859-7 cp1253 MacGreek cp737 cp869  U37-3F U1F )],
  56                 hebrew     => [qw( iso-8859-8 cp1255 MacHebrew cp862  U59-5F )],
  57                 thai       => [qw( iso-8859-11 cp874 MacThai )],
  58                 vietnamese => [qw( viscii cp1258 MacVietnamese )],
  59                 symbol     => [qw( symbol dingbats MacDingbats AdobeZdingbat AdobeSymbol )],
  60
  61                 # iso-code shorthand
  62                 1 => 'westeur',
  63                 2 => 'centeur',
  64                 3 => 'turkish',
  65                 4 => 'baltic',
  66                 5 => 'cyrillic',
  67                 6 => 'arabic',
  68                 7 => 'greek',
  69                 8 => 'hebrew',
  70                 9 => 'turkish',
  71                 10 => 'nordic',
  72                 11 => 'thai',
  73         };
  74         if (my $follow = $ALIAS->{$input}) {
  75                 tabinput($_) for ref $follow ? @{$follow} : $follow;
  76                 return;
  77         }
  78
  79         state $visible = {};  # all present tables
  80         my %row = (offset => 0, cols => 16);
  81         my $endpoint = 255;
  82         my $params = $input =~ s/[+](.*)\z// ? $1 : undef;
  83
  84         if (not defined $params) {
  85                 use List::Util qw( first pairfirst pairs );
  86
  87                 state $INHERIT = {
  88                         'cp437'       => ['cp850' => 0, 'ascii' => '0-31+128'], # ascii range overridden later
  89                         'gsm0338'     => ['ascii' => '0-127'],
  90
  91                         'iso-8859-2'  => ['iso-8859-1' => '160'],
  92                         'iso-8859-3'  => ['iso-8859-1' => '160'], #TODO: also apply to iso-8859-9
  93                         'iso-8859-4'  => ['iso-8859-2' => '160'],
  94                         'iso-8859-5'  => ['iso-8859-1' => '160'],
  95                         'iso-8859-6'  => ['cp1256' => '128', 'iso-8859-1' => '160'],
  96                         'iso-8859-7'  => ['iso-8859-1' => '160'],
  97                         'iso-8859-8'  => ['iso-8859-1' => '160'],
  98                         'iso-8859-9'  => ['iso-8859-1' => '208-223+240'],
  99                         'iso-8859-10' => ['iso-8859-4' => '160'],
 100                         'iso-8859-11' => ['iso-8859-1' => '160'],
 101                         'iso-8859-13' => ['iso-8859-4' => '160'],
 102                         'iso-8859-14' => ['iso-8859-1' => '160'],
 103                         'iso-8859-15' => ['iso-8859-1' => '160-191'],
 104                         'iso-8859-16' => ['iso-8859-2' => '160'],
 105                         'hp-roman8'   => ['iso-8859-1' => '160'],
 106
 107                         'cp1252'      => ['iso-8859-1' => '128-159'],
 108                         'cp1250'      => ['iso-8859-2' => '128-191', 'cp1252' => '128'],
 109                         'cp1254'      => ['iso-8859-9' => '128-159', 'cp1252' => '128-159+208'],
 110                         'cp874'       => ['iso-8859-11' => '128-159', 'cp1252' => '128'], # windows-874 actually cp1162
 111                         'cp1257'      => ['iso-8859-13' => '128-159+255', 'cp1252' => '128'],
 112                         'cp1251'      => ['cp1252' => '128'],
 113                         'cp1253'      => ['cp1252' => '128'],
 114                         'cp1255'      => ['iso-8859-8' => '128-223', 'cp1252' => '128'],
 115                         'cp1256'      => ['cp1252' => '128'],
 116                         'cp1258'      => ['cp1252' => '128-159+192'],
 117
 118                         'cp850'       => ['cp437' => '144'],
 119                         'cp860'       => ['cp437' => '128-175'],
 120                         'cp861'       => ['cp865' => '128-175'],
 121                         'cp863'       => ['cp437' => '128-175'],
 122                         'cp865'       => ['cp437' => '144-175'],
 123                         'cp852'       => ['cp850' => '128', 'cp437' => '128'],
 124                         'cp857'       => ['cp850' => '128-175+208-239', 'cp437' => '128'],
 125                         'cp775'       => ['cp850' => '128'],  # partial cp437
 126                         'cp866'       => ['cp437' => '128-175+224'],
 127                         'cp855'       => ['cp437' => '128'],
 128                         'cp1006'      => ['iso-8859-6' => '160', 'cp437' => '128'],
 129                         'cp737'       => ['cp437' => '128-175+224'],
 130                         'cp869'       => ['cp437' => '128'],
 131                         'cp862'       => ['cp437' => '128-159'],
 132                         'cp864'       => ['MacArabic' => '128', 'iso-8859-6' => '128', 'cp437' => '128'], #TODO: compare form variants
 133
 134                         'koi8-u'      => ['koi8-r' => 128],
 135                         'koi8-f'      => ['koi8-u' => 128],
 136
 137                         'MacRomanian' => ['MacRoman' => '160-191+208-223'],
 138                         'MacRumanian' => ['MacRomanian' => '160-191+208-223', 'MacRoman' => '160-191+208-223'],
 139                         'MacCroatian' => ['MacRoman' => '160'],
 140                         'MacCentralEurRoman' => ['MacRoman' => '128'],
 141                         'MacIcelandic'=> ['MacRoman' => '160-175+208-239'], #TODO: gaps at C/E
 142                         'MacTurkish'  => ['MacRoman' => '208-223'], # F5 is unassigned
 143                         'MacSami'     => ['MacIcelandic' => '144', 'MacRoman' => '144'],
 144                         'MacGreek'    => ['MacRoman' => '128'],
 145                         'MacCyrillic' => ['MacRoman' => '128'],
 146                         'MacHebrew'   => ['iso-8859-8' => '128', 'MacRoman' => '128-143+160'], # partial ascii
 147                         'MacArabic'   => ['iso-8859-6' => '128', 'cp864' => '128', 'MacRoman' => '128'], #TODO: multiple parents
 148                         'MacFarsi'    => ['MacArabic' => '176-191', 'MacRoman' => '128'],
 149
 150                         'cp37'        => ['posix-bc' => '0'],
 151                         'posix-bc'    => ['cp1047' => '64'],
 152                         'cp500'       => ['cp37' => '64-95+176-191'],
 153                         'cp1047'      => ['cp37' => '16-95+160-191'], #TODO: gap at 3/4
 154                         'cp1026'      => ['cp37' => '64'],
 155                         'cp875'       => ['cp37' => '48'],
 156
 157                 };
 158
 159                 my @parents = @{ $INHERIT->{$input} || [] };
 160
 161                 if (my ($parent, $part) = pairfirst { defined $visible->{$a} } @parents) {
 162                         $row{parent} = $parent;
 163                         $params = $part;
 164                         $params = 128 unless $visible->{$parent}
 165                                 or ($input eq 'MacCroatian' and defined $visible->{MacRomanian});
 166                 }
 167                 elsif (defined $visible->{ascii}) {
 168                         $row{parent} = $parents[0];
 169                         $params = $parents[1] // 128;
 170                         $params = 128 if $params >= 128;  # ascii offset at most
 171                 }
 172                 elsif (@parents) {
 173                         $row{parent} = $parents[0];
 174                         $params = $parents[1] if $parents[1] == 0;  # apply ascii end
 175                 }
 176                 $visible->{$_} //= 0 for $row{parent} || ();
 177         }
 178         else {
 179                 # manual option to double table width
 180                 $row{cols} *= 2 if $params =~ s/[+]\z//;
 181         }
 182
 183         if (length $params) {
 184                 $params =~ m{
 185                         \A (?<offset> \d+)
 186                         (?: (?: [-] (?<stop> \d+) )? (?: [+] (?<restart> \d+) ) )?
 187                         (?: [-] (?<endpoint> \d+) )? \z
 188                 }x or Alert([
 189                         "Unknown range parameters for $input",
 190                         "<q>$params</q> is not in format start(-stop)(+restart(-end))",
 191                 ]);
 192
 193                 $row{offset} = $+{offset};
 194                 $endpoint = $+{endpoint} if $+{endpoint};
 195                 if (my $restart = $+{restart}) {
 196                         my $skip = int(($+{stop} || $row{offset}) / $row{cols});
 197                         for ($skip + 1 .. ($restart / $row{cols}) - 1) {
 198                                 $row{skip}->{ $_ * $row{cols} - $row{offset} }++;
 199                         }
 200                 }
 201         }
 202
 203         if ($input =~ /^U([0-9a-fA-F]+)(?:-([0-9a-fA-F]+))?/) {
 204                 my $start = hex($1) << ($2 ? 4 : 8);
 205                 my $end = $2 ? (hex($2) << 4) + $row{cols} - 1 : $start + 255;
 206                 $row{table} = join '', map { chr } $start .. $end;
 207                 utf8::upgrade($row{table});  # prevent latin1 output
 208                 $row{endpoint} = $end - $start;
 209                 $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
 210                 $row{offset} = $start % 256;
 211         }
 212         elsif ($input eq 'U') {
 213                 $row{set} = 'Unicode planes';
 214                 $row{cell} = do 'charset-ucplanes.inc.pl'
 215                         or Alert('Table data could not be read', $@ || $!);
 216                 $row{cols} *= 2;
 217                 $row{endpoint} = 1023 * $row{cell}->{colsize};
 218         }
 219         elsif ($row{set} = Encode::resolve_alias($input)) {
 220                 if ($row{set} eq 'Internal') {
 221                         $row{set} = 'Unicode BMP';
 222                         $row{cell} = do 'charset-unicode.inc.pl'
 223                                 or Alert('Table data could not be read', $@ || $!);
 224                         $row{endpoint} = ($endpoint || 8191) * $row{cell}->{colsize};
 225                 }
 226                 elsif ($row{set} eq 'utf-8-strict') {
 227                         $row{set} = 'UTF-8';
 228                         $row{cell} = do 'charset-utf8.inc.pl'
 229                                 or Alert('Table data could not be read', $@ || $!);
 230                         $row{endpoint} = 255;
 231                 }
 232                 else {
 233                         if ($row{set} eq 'MacHebrew' or $row{set} eq 'MacThai') {
 234                                 # array of possibly multiple characters per code point
 235                                 $row{table} = [
 236                                         map { Encode::decode($row{set}, pack 'C*', $_) } $row{offset} .. $endpoint
 237                                 ];
 238                         }
 239                         else {
 240                                 # ~16x faster than decoding in loop;
 241                                 # substr strings is twice as fast as splitting to an array
 242                                 $row{table} = Encode::decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
 243                         }
 244                         $row{endpoint} = $endpoint - $row{offset};
 245
 246                         if ($row{set} eq 'cp437' and !$row{offset}) {
 247                                 substr($row{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
 248                                 substr($row{table}, 0, 32) = pack 'U*', map {hex} qw(
 249                                         2007 263A 263B 2665 2666 2663 2660 2022
 250                                         25D8 25CB 25D9 2642 2640 266A 266B 263C
 251                                         25BA 25C4 2195 203C 00B6 00A7 25AC 21A8
 252                                         2191 2193 2192 2190 221F 2194 25B2 25BC
 253                                 );
 254                         }
 255
 256                         $visible->{ascii} =  # assume common base
 257                         $visible->{ $row{set} } = 1;
 258                 }
 259         }
 260         else {
 261                 Alert("Encoding <q>$input</q> unknown");
 262                 return;
 263         }
 264         push @request, \%row;
 265 }
 266 tabinput($_) for @tablist;
 267
 268 my $NOCHAR = chr 0xFFFD;
 269
 270 sub range_cell {
 271         my ($info, $offset) = @_;
 272         my $table = $info->{cell} or return;
 273         my $def = $table->{$offset} or return;
 274         my ($len, $class, $name, $title) = @{$def};
 275
 276         my $cols = $info->{cols};
 277         my $colsize = $table->{colsize} || 1;
 278         my $attr = '';
 279         $len /= $colsize;
 280         $name //= $len <= 2 ? 'res' : 'reserved';
 281
 282         if (my $part = $offset/$colsize % $cols) {
 283                 # continued row
 284                 my $rest = $cols - $part;  # remaining
 285                 $rest = $len if $len < $rest; #TODO: optimise
 286                 if ($len -= $rest) {
 287                         # continued on new row
 288                         my @next = ($len * $colsize, "$class joinu");
 289                         if ($len > $rest) {
 290                                 # minority remains
 291                                 push @next, $name, $title;
 292                                 $title ||= $name;
 293                                 $name = '';
 294                         }
 295                         else {
 296                                 # minority on next row
 297                                 push @next, '"', $title || $name;
 298                         }
 299                         $table->{$offset + $colsize*$rest} //= \@next;
 300                         $class .= ' joind';
 301                 }
 302                 $len = $rest;
 303         }
 304         elsif (my $rows = int($len / $cols)) {
 305                 # multiple full rows
 306                 if ($len -= $rows * $cols) {
 307                         # partial row remains
 308                         $table->{$offset + $colsize*$rows * $cols} //= [$len*$colsize, "$class joinu", '', $title];
 309                         $class .= ' joind';
 310                 }
 311                 $attr .= sprintf ' rowspan=%d', $rows;
 312                 $len = $cols;
 313         }
 314
 315         $attr .= sprintf ' colspan=%d', $len unless $len == 1;
 316         $attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
 317         $attr .= sprintf ' class="%s"', $class if $class;
 318         $attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
 319         return "<td$attr>$name";
 320 }
 321
 322 for my $row (@request) {
 323         my $cols = $row->{cols};
 324         my $colsize = $row->{cell} && $row->{cell}->{colsize} || 1;
 325         my $coldigits = ceil(log($colsize * $cols) / log(16));  # uniform length of hexadecimal header
 326         my $rowdiv = 16 ** $coldigits;  # row divide for column digits
 327         $rowdiv = 1 if $rowdiv != $cols * $colsize;  # divide only if all columns are matched
 328         my $offset = 0;
 329
 330         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 331         my $title = $row->{set};
 332         $title .= " <aside>(over $_)</aside>"
 333                 for grep { $_ ne 'iso-8859-1' } $row->{parent} // ();
 334         printf '<caption>%s</caption>', $title;
 335         print '<col>' x ($cols + 1);
 336         for my $section (qw{thead}) {
 337                 print "<$section><tr><th>", $rowdiv == 1 ? '+' : '↱';
 338                 printf '<th>%0*X', $coldigits, $_ * $colsize for 0 .. $cols - 1;
 339                 print "\n";
 340         }
 341         print '<tbody>';
 342         while ($offset < $row->{endpoint}) {
 343                 if ($row->{skip}->{$offset}) {
 344                         $offset += $cols * $colsize;
 345                         next;
 346                 }
 347
 348                 print '<tr><th>';
 349                 {
 350                         if (my $rowmod = $offset % $rowdiv) {
 351                                 # offset in column units
 352                                 printf '<small>+%X</small>', $rowmod;
 353                         }
 354                         else {
 355                                 # divided row offset
 356                                 printf '%X', ($offset + $row->{offset}) / $rowdiv;
 357                         }
 358                 }
 359                 for (1 .. $cols) {
 360                         if ($row->{cell}) {
 361                                 print range_cell($row, $offset);
 362                                 next;
 363                         }
 364
 365                         my $glyph = ref $row->{table} eq 'ARRAY' ? $row->{table}->[$offset] :
 366                                 substr $row->{table}, $offset, 1;
 367                         if ($glyph eq $NOCHAR) {
 368                                 print '<td>';
 369                                 next;
 370                         }
 371
 372                         if (exists $get{compare}) {
 373                                 state $visible = {};
 374                                 my $cp = $offset + $row->{offset};
 375                                 printf '<td class="%s" title="%3$s">%2$s',
 376                                         $cp == ord $glyph ? 'l4' :
 377                                         $row->{parent} && $glyph eq
 378                                                 Encode::decode($row->{parent}, pack 'C', $cp) ? 'l3' :
 379                                         $visible->{$glyph} ? 'l2' :
 380                                         'l1',
 381                                         $glyphs->glyph_html($glyph);
 382                                 $visible->{$glyph}++;
 383                                 next;
 384                         }
 385
 386                         print "\n".$glyphs->glyph_cell($glyph);
 387                 }
 388                 continue {
 389                         $offset += $colsize;
 390                 }
 391                 print "\n";
 392         }
 393         say '</table></div>';
 394 }
 395
 396 :>
 397 <hr>
 398
 399 <div class="legend">
 400         <table class="glyphs"><tr><: if (exists $get{compare}) { :>
 401         <td class="X l4">unicode
 402         <td class="X l3">inherited
 403         <td class="X l2">existing
 404         <td class="X l1">original
 405         <td class="">unassigned
 406 <: } else { :>
 407         <td class="X Cc">control
 408         <td class="X Zs"><span>whitespace</span>
 409         <td class="X Mn">diacritic<table class="glyphs"><tr>
 410                 <td class="X Sk">letter
 411                 </table>
 412         <td class="X Po">punctuation<table class="glyphs"><tr>
 413                 <td class="X Pf">quote
 414                 </table>
 415         <td class="X So">symbol<table class="glyphs"><tr>
 416                 <td class="X Sm">math
 417                 <td class="X Sc">currency
 418                 </table>
 419         <td class="X No">numeric
 420         <td class="X Greek">greek<table class="glyphs"><tr>
 421                 <td class="X Latin">latin
 422                 <td class="X Cyrillic">cyrillic
 423                 </table>
 424         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 425                 <td class="X Brahmic">brahmic
 426                 <td class="X Arabic">arabic
 427                 </table>
 428         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 429                 <td class="X African">african
 430                 <td class="X Hiragana">japanese
 431                 <td class="X Han">cjk
 432                 <td class="X Bopomofo">chinese
 433                 </table>
 434         <td class="X Alpha">alphabetic
 435         </table>
 436
 437         <table class="glyphs"><tr>
 438         <td class="X">unicode 7.0
 439         <td class="X Xr">proposed
 440         <td class="X Xd">deprecated
 441         <td class="">unassigned
 442         <td class="X Xi">invalid
 443 <: } :> </table>
 444 </div>
 445