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