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 { $visible->{$a} } @parents) {
 141                         $row{parent} = $parent;
 142                         $params = $part;
 143                 }
 144                 elsif ($visible->{ascii}) {
 145                         $row{parent} = $parents[0] || 'ascii';
 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         }
 153
 154         if (defined $params and $params =~ m/^ (\d+) (-\d+)? /x) {
 155                 $row{offset} = $1;
 156                 $endpoint = -$2 if $2;
 157         }
 158
 159         if ($input =~ /^U([0-9a-f]+)(?:-([0-9a-f]+))?/) {
 160                 my $start = hex($1) << ($2 ? 4 : 8);
 161                 my $end = $2 ? hex($2) << 4 : $start + 240;
 162                 $row{table} = join '', map { chr } $start .. $end+15;
 163                 utf8::upgrade($row{table});  # prevent latin1 output
 164                 $row{len} = length $row{table};
 165                 $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
 166         }
 167         elsif ($input eq 'U') {
 168                 $row{len} = 1024;
 169                 $row{set} = 'Unicode planes';
 170                 $row{cell} = do 'charset-ucplanes.inc.pl'
 171                         or Alert('Table data could not be read', $@ || $!);
 172                 $row{cols} *= 2;
 173         }
 174         elsif ($row{set} = Encode::resolve_alias($input)) {
 175                 if ($row{set} eq 'Internal') {
 176                         $row{len} = $endpoint < 255 ? 640 : 8192;
 177                         $row{set} = 'Unicode BMP';
 178                         $row{cell} = do 'charset-unicode.inc.pl'
 179                                 or Alert('Table data could not be read', $@ || $!);
 180                 }
 181                 elsif ($row{set} eq 'utf-8-strict') {
 182                         $row{len} = 256;
 183                         $row{set} = 'UTF-8';
 184                         $row{cell} = do 'charset-utf8.inc.pl'
 185                                 or Alert('Table data could not be read', $@ || $!);
 186                 }
 187                 else {
 188                         if ($row{set} eq 'MacHebrew') {
 189                                 # array of possibly multiple characters per code point
 190                                 $row{table} = [
 191                                         map { Encode::decode($row{set}, pack 'C*', $_) } $row{offset} .. $endpoint
 192                                 ];
 193                         }
 194                         else {
 195                                 # ~16x faster than decoding in loop;
 196                                 # substr strings is twice as fast as splitting to an array
 197                                 $row{table} = Encode::decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
 198                         }
 199                         $row{len} = $endpoint - $row{offset};
 200
 201                         if ($row{set} eq 'cp437' and !$row{offset}) {
 202                                 substr($row{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
 203                                 substr($row{table}, 0, 32) = pack 'U*', map {hex} qw(
 204                                         2007 263A 263B 2665 2666 2663 2660 2022
 205                                         25D8 25CB 25D9 2642 2640 266A 266B 263C
 206                                         25BA 25C4 2195 203C 00B6 00A7 25AC 21A8
 207                                         2191 2193 2192 2190 221F 2194 25B2 25BC
 208                                 );
 209                         }
 210
 211                         $visible->{ascii} =  # assume common base
 212                         $visible->{ $row{set} } = 1;
 213                 }
 214         }
 215         else {
 216                 Alert("Encoding <q>$input</q> unknown");
 217                 return;
 218         }
 219         push @request, \%row;
 220 }
 221 tabinput($_) for @tablist;
 222
 223 my $NOCHAR = chr 0xFFFD;
 224
 225 sub range_cell {
 226         my ($info, $offset) = @_;
 227         my $table = $info->{cell} or return;
 228         my $def = $table->{$offset} or return;
 229         my ($len, $class, $name, $title) = @{$def};
 230
 231         my $cols = $info->{cols};
 232         my $colsize = $table->{colsize} || 1;
 233         my $attr = '';
 234         $len /= $colsize;
 235         $name //= $len <= 2 ? 'res' : 'reserved';
 236
 237         if (my $part = $offset/$colsize % $cols) {
 238                 # continued row
 239                 my $rest = $cols - $part;  # remaining
 240                 $rest = $len if $len < $rest; #TODO: optimise
 241                 if ($len -= $rest) {
 242                         # continued on new row
 243                         my @next = ($len * $colsize, "$class joinu");
 244                         if ($len > $rest) {
 245                                 # minority remains
 246                                 push @next, $name, $title;
 247                                 $title ||= $name;
 248                                 $name = '';
 249                         }
 250                         else {
 251                                 # minority on next row
 252                                 push @next, '"', $title || $name;
 253                         }
 254                         $table->{$offset + $colsize*$rest} //= \@next;
 255                         $class .= ' joind';
 256                 }
 257                 $len = $rest;
 258         }
 259         elsif (my $rows = int($len / $cols)) {
 260                 # multiple full rows
 261                 if ($len -= $rows * $cols) {
 262                         # partial row remains
 263                         $table->{$offset + $colsize*$rows * $cols} //= [$len*$colsize, "$class joinu", '', $title];
 264                         $class .= ' joind';
 265                 }
 266                 $attr .= sprintf ' rowspan=%d', $rows;
 267                 $len = $cols;
 268         }
 269
 270         $attr .= sprintf ' colspan=%d', $len unless $len == 1;
 271         $attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
 272         $attr .= sprintf ' class="%s"', $class if $class;
 273         $attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
 274         return "<td$attr>$name";
 275 }
 276
 277 for my $row (@request) {
 278         my $cols = $row->{cols};
 279         my $colsize = $row->{cell} && $row->{cell}->{colsize} || 1;
 280         my $coldigits = ceil(log($colsize * $cols) / log(16));  # uniform length of hexadecimal header
 281         my $rowdiv = 16 ** $coldigits;  # row divide for column digits
 282         $rowdiv = 1 if $rowdiv != $cols * $colsize;  # divide only if all columns are matched
 283         my $offset = 0;
 284         my $endpoint = $offset + $row->{len} * $colsize;
 285
 286         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 287         my $title = $row->{set};
 288         $title .= " <aside>(over $_)</aside>"
 289                 for grep { $_ ne 'iso-8859-1' } $row->{parent} // ();
 290         printf '<caption>%s</caption>', $title;
 291         print '<col>' x ($cols + 1);
 292         for my $section (qw{thead}) {
 293                 print "<$section><tr><th>", $rowdiv == 1 ? '+' : '↱';
 294                 printf '<th>%0*X', $coldigits, $_ * $colsize for 0 .. $cols - 1;
 295                 print "\n";
 296         }
 297         print '<tbody>';
 298         while ($offset < $endpoint - 1) {
 299                 print '<tr><th>';
 300                 {
 301                         if (my $rowmod = $offset % $rowdiv) {
 302                                 # offset in column units
 303                                 printf '<small>+%X</small>', $rowmod;
 304                         }
 305                         else {
 306                                 # divided row offset
 307                                 printf '%X', ($offset + $row->{offset}) / $rowdiv;
 308                         }
 309                 }
 310                 for (1 .. $cols) {
 311                         if ($row->{cell}) {
 312                                 print range_cell($row, $offset);
 313                                 next;
 314                         }
 315
 316                         my $glyph = ref $row->{table} eq 'ARRAY' ? $row->{table}->[$offset] :
 317                                 substr $row->{table}, $offset, 1;
 318                         if ($glyph eq $NOCHAR) {
 319                                 print '<td>';
 320                                 next;
 321                         }
 322
 323                         print "\n".$glyphs->glyph_cell($glyph);
 324                 }
 325                 continue {
 326                         $offset += $colsize;
 327                 }
 328                 print "\n";
 329         }
 330         say '</table></div>';
 331 }
 332
 333 :>
 334 <hr>
 335
 336 <div class="legend">
 337         <table class="glyphs"><tr>
 338         <td class="X Cc">control
 339         <td class="X Zs"><span>whitespace</span>
 340         <td class="X Mn">diacritic<table class="glyphs"><tr>
 341                 <td class="X Sk">letter
 342                 </table>
 343         <td class="X Po">punctuation<table class="glyphs"><tr>
 344                 <td class="X Pf">quote
 345                 </table>
 346         <td class="X So">symbol<table class="glyphs"><tr>
 347                 <td class="X Sm">math
 348                 <td class="X Sc">currency
 349                 </table>
 350         <td class="X No">numeric
 351         <td class="X Greek">greek<table class="glyphs"><tr>
 352                 <td class="X Latin">latin
 353                 <td class="X Cyrillic">cyrillic
 354                 </table>
 355         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 356                 <td class="X Brahmic">brahmic
 357                 <td class="X Arabic">arabic
 358                 </table>
 359         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 360                 <td class="X African">african
 361                 <td class="X Hiragana">japanese
 362                 <td class="X Han">cjk
 363                 <td class="X Bopomofo">chinese
 364                 </table>
 365         <td class="X Alpha">alphabetic
 366         </table>
 367
 368         <table class="glyphs"><tr>
 369         <td class="X">unicode 7.0
 370         <td class="X Xr">proposed
 371         <td class="X Xd">deprecated
 372         <td class="">unassigned
 373         <td class="X Xi">invalid
 374         </table>
 375 </div>
 376