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