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                 my $rowsize = $colsize * $cols;
 307                 if ($len -= $rows * $cols) {
 308                         # partial row remains
 309                         $table->{$offset + $rowsize * $rows} //= [$len*$colsize, "$class joinu", '', $title];
 310                         $class .= ' joind';
 311                 }
 312
 313                 # coalesce multiple rows
 314                 while ($rows > 3) {
 315                         $info->{skip}->{$offset += $rowsize}++;
 316                         $rows--;
 317                 }
 318                 if ($rows > 2) {
 319                         $info->{skip}->{$offset += $rowsize} = 0;
 320                 }
 321
 322                 $attr .= sprintf ' rowspan=%d', $rows;
 323                 $len = $cols;
 324         }
 325
 326         $attr .= sprintf ' colspan=%d', $len unless $len == 1;
 327         $attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
 328         $attr .= sprintf ' class="%s"', $class if $class;
 329         $attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
 330         return "<td$attr>$name";
 331 }
 332
 333 for my $row (@request) {
 334         my $cols = $row->{cols};
 335         my $colsize = $row->{cell} && $row->{cell}->{colsize} || 1;
 336         my $coldigits = ceil(log($colsize * $cols) / log(16));  # uniform length of hexadecimal header
 337         my $rowdiv = 16 ** $coldigits;  # row divide for column digits
 338         $rowdiv = 1 if $rowdiv != $cols * $colsize;  # divide only if all columns are matched
 339         my $offset = 0;
 340
 341         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 342         my $title = $row->{set};
 343         $title .= " <aside>(over $_)</aside>"
 344                 for grep { $_ ne 'iso-8859-1' } $row->{parent} // ();
 345         printf '<caption>%s</caption>', $title;
 346         print '<col>' x ($cols + 1);
 347         for my $section (qw{thead}) {
 348                 print "<$section><tr><th>", $rowdiv == 1 ? '+' : '↱';
 349                 printf '<th>%0*X', $coldigits, $_ * $colsize for 0 .. $cols - 1;
 350                 print "\n";
 351         }
 352         print '<tbody>';
 353         while ($offset < $row->{endpoint}) {
 354                 if ($row->{skip}->{$offset}) {
 355                         $offset += $cols * $colsize;
 356                         next;
 357                 }
 358
 359                 print '<tr><th>';
 360                 if (defined $row->{skip}->{$offset}) {
 361                         print '⋮';
 362                 }
 363                 else {
 364                         if (my $rowmod = $offset % $rowdiv) {
 365                                 # offset in column units
 366                                 printf '<small>+%X</small>', $rowmod;
 367                         }
 368                         else {
 369                                 # divided row offset
 370                                 printf '%X', ($offset + $row->{offset}) / $rowdiv;
 371                         }
 372                 }
 373                 for (1 .. $cols) {
 374                         if ($row->{cell}) {
 375                                 print range_cell($row, $offset);
 376                                 next;
 377                         }
 378
 379                         my $glyph = ref $row->{table} eq 'ARRAY' ? $row->{table}->[$offset] :
 380                                 substr $row->{table}, $offset, 1;
 381                         if ($glyph eq $NOCHAR) {
 382                                 print '<td>';
 383                                 next;
 384                         }
 385
 386                         if (exists $get{compare}) {
 387                                 state $visible = {};
 388                                 my $cp = $offset + $row->{offset};
 389                                 printf '<td class="%s" title="%3$s">%2$s',
 390                                         $cp == ord $glyph ? 'l4' :
 391                                         $row->{parent} && $glyph eq
 392                                                 Encode::decode($row->{parent}, pack 'C', $cp) ? 'l3' :
 393                                         $visible->{$glyph} ? 'l2' :
 394                                         'l1',
 395                                         $glyphs->glyph_html($glyph);
 396                                 $visible->{$glyph}++;
 397                                 next;
 398                         }
 399
 400                         print "\n".$glyphs->glyph_cell($glyph);
 401                 }
 402                 continue {
 403                         $offset += $colsize;
 404                 }
 405                 print "\n";
 406         }
 407         say '</table></div>';
 408 }
 409
 410 :>
 411 <hr>
 412
 413 <div class="legend">
 414         <table class="glyphs"><tr><: if (exists $get{compare}) { :>
 415         <td class="X l4">unicode
 416         <td class="X l3">inherited
 417         <td class="X l2">existing
 418         <td class="X l1">original
 419         <td class="">unassigned
 420 <: } else { :>
 421         <td class="X Cc">control
 422         <td class="X Zs"><span>whitespace</span>
 423         <td class="X Mn">diacritic<table class="glyphs"><tr>
 424                 <td class="X Sk">letter
 425                 </table>
 426         <td class="X Po">punctuation<table class="glyphs"><tr>
 427                 <td class="X Pf">quote
 428                 </table>
 429         <td class="X So">symbol<table class="glyphs"><tr>
 430                 <td class="X Sm">math
 431                 <td class="X Sc">currency
 432                 </table>
 433         <td class="X No">numeric
 434         <td class="X Greek">greek<table class="glyphs"><tr>
 435                 <td class="X Latin">latin
 436                 <td class="X Cyrillic">cyrillic
 437                 </table>
 438         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 439                 <td class="X Brahmic">brahmic
 440                 <td class="X Arabic">arabic
 441                 </table>
 442         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 443                 <td class="X African">african
 444                 <td class="X Hiragana">japanese
 445                 <td class="X Han">cjk
 446                 <td class="X Bopomofo">chinese
 447                 </table>
 448         <td class="X Alpha">alphabetic
 449         </table>
 450
 451         <table class="glyphs"><tr>
 452         <td class="X">unicode 7.0
 453         <td class="X Xr">proposed
 454         <td class="X Xd">deprecated
 455         <td class="">unassigned
 456         <td class="X Xi">invalid
 457 <: } :> </table>
 458 </div>
 459