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