charset.plp

   1 <(common.inc.plp)><:
   2 use 5.014;
   3
   4 Html({
   5         title => 'charset cheat sheet',
   6         version => '1.0',
   7         description => [
   8                 "Reference sheet with all glyphs in common character encoding tables,",
   9                 "and an overview of Unicode ranges and UTF-8 bytes.",
  10         ],
  11         keywords => [qw'
  12                 charset codepage unicode ascii utf8 latin glyph character encoding
  13                 reference common overview table
  14         '],
  15         stylesheet => [qw'light'],
  16         data => [qw'charset-unicode.inc.pl charset-utf8.inc.pl'],
  17 });
  18
  19 :>
  20 <h1>Character encoding</h1>
  21
  22 <:
  23 use Shiar_Sheet::FormatChar;
  24 my $glyphs = Shiar_Sheet::FormatChar->new;
  25 my @nibble = (0..9, 'A'..'F');
  26 my $nibsize = 1;
  27
  28 use Encode qw(decode resolve_alias);
  29 # generate character table(s)
  30 # (~16x faster than decoding in loop;
  31 #  substr strings is twice as fast as splitting to an array)
  32 my %ALIAS = (
  33 #       default => [qw(unicode utf-8 iso-8859-1 cp437 -cp1252- --iso-8859-15- -koi8-f)],
  34         default => [qw(unicode- utf-8 iso-8859-1 -cp1252- --iso-8859-15- cp437 -cp850)],
  35         0 => [qw(cp437 -cp863)],
  36         1 => [qw(iso-8859-1 -cp1252 -MacRoman -cp850)],
  37         2 => [qw(iso-8859-2 -cp1250 -cp852 -MacCentralEurRoman -MacCroatian -MacRumanian)],
  38         5 => [qw(koi8-f -iso-8859-5 -cp1251 -MacCyrillic -cp855 -cp866)],
  39         7 => [qw(iso-8859-7 -cp1253 -MacGreek -cp737 -cp869)],
  40         8 => [qw(iso-8859-8 -cp1255 -MacHebrew -cp862)],
  41 );
  42 my @request = map {
  43         if (my $input = $_) {
  44                 my %row = (offset => 0);
  45                 my $endpoint = 255;
  46                 if ($input =~ s/^--//) {
  47                         $row{offset} = $endpoint > 160 ? 160 : 48;
  48                 }
  49                 elsif ($input =~ s/^-//) {
  50                         $row{offset} = $endpoint > 128 ? 128 : 32;
  51                 }
  52                 if ($input =~ s/-$//) {
  53                         $endpoint = $row{offset} ? $row{offset} < 160 ? 159 : 191 : 127;
  54                 }
  55                 if ($row{offset}) {
  56                         $row{setnote} = 'over cp437' if $input eq 'cp850';
  57                         $row{setnote} = 'over iso-8859-1' if $input =~ /^iso-8859-|^cp125/;
  58                 }
  59
  60                 if ($input =~ /^U([0-9a-f]+)(?:-([0-9a-f]+))?/) {
  61                         my $start = hex($1) << ($2 ? 4 : 8);
  62                         my $end = $2 ? hex($2) << 4 : $start + 240;
  63                         $row{table} = join '', map { chr } $start .. $end+15;
  64                         utf8::upgrade($row{table});  # prevent latin1 output
  65                         $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
  66                 }
  67                 elsif ($input eq 'U') {
  68                         $row{table} = ' ' x 1024;
  69                         $row{set} = 'Unicode planes';
  70                         $row{cell} = do 'charset-ucplanes.inc.pl'
  71                                 or printf "<p class=error>Table data could not be read: <em>%s</em>.</p>\n", $@ || $!;
  72                         @nibble = (map { $_.0, $_.8 } 0 .. 7);
  73                         $nibsize = 8;
  74                 }
  75                 elsif ($row{set} = 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 printf "<p class=error>Table data could not be read: <em>%s</em>.</p>\n", $@ || $!;
  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 printf "<p class=error>Table data could not be read: <em>%s</em>.</p>\n", $@ || $!;
  87                         }
  88                         else {
  89                                 $row{table} = decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
  90                         }
  91                 }
  92                 else {
  93                         say "<p class=error>Encoding <q>$input</q> unknown</p>";
  94                 }
  95                 $row{set} ? \%row : ();
  96         }
  97         else {
  98                 ();
  99         }
 100 } map { defined $ALIAS{$_} ? @{ $ALIAS{$_} } : $_ }
 101         $ENV{PATH_INFO} =~ /\w/ ? split(m{[/+\s]}, $ENV{PATH_INFO}) : 'default';
 102 my $NOCHAR = chr 0xFFFD;
 103
 104 for my $cp437 (grep {$request[$_]->{set} eq 'cp437'} 0 .. $#request) {
 105         substr($request[$cp437]->{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
 106         substr($request[$cp437]->{table}, 0, 32) = pack 'U*', map {hex} qw(
 107                 2007 263A 263B 2665 2666 2663 2660 2022 25D8 25CB 25D9 2642 2640 266A 266B 263C
 108                 25BA 25C4 2195 203C 00B6 00A7 25AC 21A8 2191 2193 2192 2190 221F 2194 25B2 25BC
 109         );
 110 }
 111
 112 sub range_cell {
 113         my ($table, $offset) = @_;
 114         my $def = $table->{$offset} or return;
 115         my ($len, $class, $name, $title) = @{$def};
 116
 117         my $attr = '';
 118         $len /= $nibsize;
 119         $name //= $len <= 2 ? 'res' : 'reserved';
 120
 121         if (my $part = $offset/$nibsize % 16) {
 122                 # continued row
 123                 my $cols = 16 - $part;  # remaining
 124                 $cols = $len if $len < $cols; #TODO: optimise
 125                 if ($len -= $cols) {
 126                         # continued on new row
 127                         $table->{$offset + $nibsize*$cols} = [$len*$nibsize, "$class joinu", $name, $title];
 128                         $name = '';
 129                         $class .= ' joind';
 130                 }
 131                 $len = $cols;
 132         }
 133         elsif (my $rows = $len >> 4) {
 134                 # multiple full rows
 135                 if ($len -= $rows << 4) {
 136                         # partial row remains
 137                         $table->{$offset + $nibsize*$rows * 16} = [$len*$nibsize, "$class joinu", '', $title];
 138                         $class .= ' joind';
 139                 }
 140                 $attr .= sprintf ' rowspan=%d', $rows;
 141                 $len = 16;
 142         }
 143
 144         $attr .= sprintf ' colspan=%d', $len unless $len == 1;
 145         $attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
 146         $attr .= sprintf ' class="%s"', $class if $class;
 147         $attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
 148         return "<td$attr>$name";
 149 }
 150
 151 for my $row (@request) {
 152         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 153         my $title = $row->{set};
 154         $title .= " <aside>($_)</aside>" for $row->{setnote} // ();
 155         printf '<caption>%s</caption>', $title;
 156         print '<col>' x 17;
 157         for my $section (qw{thead}) {
 158                 print "<$section><tr><th>↱";
 159                 print '<th>', $_ for @nibble;
 160                 print "\n";
 161         }
 162         print '<tbody>';
 163         for my $msb (0 .. (length($row->{table}) || 256) - 1 >> 4) {
 164                 printf '<tr><th>%X', ($msb + ($row->{offset} >> 4)) * $nibsize;
 165                 for my $lsb (0 .. $#nibble) {
 166                         my $val = ( ($msb<<4) + $lsb ) * $nibsize;
 167                         if ($row->{cell}) {
 168                                 if (ref $row->{cell} eq 'CODE') {
 169                                         print $row->{cell}->($val);
 170                                         next;
 171                                 }
 172                                 print range_cell($row->{cell}, $val);
 173                                 next;
 174                         }
 175
 176                         my $glyph = substr $row->{table}, $val, 1;
 177                         if ($glyph eq $NOCHAR) {
 178                                 print '<td>';
 179                                 next;
 180                         }
 181
 182                         print "\n".$glyphs->glyph_cell($glyph);
 183                 }
 184                 print "\n";
 185         }
 186         print "</table></div>\n";
 187 }
 188
 189 :>
 190 <hr>
 191
 192 <div class="legend">
 193         <table class="glyphs"><tr>
 194         <td class="X Cc">control
 195         <td class="X Zs"><span>whitespace</span>
 196         <td class="X Mn">diacritic<table class="glyphs"><tr>
 197                 <td class="X Sk">letter
 198                 </table>
 199         <td class="X Po">punctuation<table class="glyphs"><tr>
 200                 <td class="X Pf">quote
 201                 </table>
 202         <td class="X So">symbol<table class="glyphs"><tr>
 203                 <td class="X Sm">math
 204                 <td class="X Sc">currency
 205                 </table>
 206         <td class="X No">numeric
 207         <td class="X Greek">greek<table class="glyphs"><tr>
 208                 <td class="X Latin">latin
 209                 <td class="X Cyrillic">cyrillic
 210                 </table>
 211         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 212                 <td class="X Brahmic">brahmic
 213                 <td class="X Arabic">arabic
 214                 </table>
 215         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 216                 <td class="X African">african
 217                 <td class="X Hiragana">japanese
 218                 <td class="X Han">cjk
 219                 <td class="X Bopomofo">chinese
 220                 </table>
 221         <td class="X Alpha">alphabetic
 222         </table>
 223
 224         <table class="glyphs"><tr>
 225         <td class="X">unicode 7.0
 226         <td class="X Xr">proposed
 227         <td class="X Xd">deprecated
 228         <td class="">unassigned
 229         <td class="X Xi">invalid
 230         </table>
 231 </div>
 232