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