charset.plp

   1 <(common.inc.plp)><:
   2         our $VERSION = 'v1.0';
   3
   4 :><!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
   5  "http://www.w3.org/TR/html4/loose.dtd">
   6 <html>
   7
   8 <head>
   9 <meta http-equiv="content-type" content="<:= $header{content_type} :>">
  10 <title>charset cheat sheet</title>
  11 <:= stylesheet(qw'light') :>
  12 </head>
  13
  14 <body id="charset">
  15 <h1>Character encoding</h1>
  16
  17 <:
  18 my $diinfo = do 'digraphs.inc.pl';
  19 my %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} }
  20         keys %$diinfo;
  21
  22 use Encode qw(decode resolve_alias);
  23 # generate character table(s)
  24 # (~16x faster than decoding in loop;
  25 #  substr strings is twice as fast as splitting to an array)
  26 my %ALIAS = (
  27 #       default => [qw(unicode utf-8 iso-8859-1 cp437 -cp1252- --iso-8859-15- -koi8-f)],
  28         default => [qw(unicode- utf-8 iso-8859-1 -cp1252- --iso-8859-15- cp437 -cp850)],
  29         0 => [qw(cp437 cp863)],
  30         1 => [qw(iso-8859-1 cp1252 MacRoman cp850)],
  31         2 => [qw(iso-8859-2 cp1250 cp852 MacCentralEurRoman MacCroatian MacRumanian)],
  32         5 => [qw(koi8-f iso-8859-5 cp1251 MacCyrillic cp855 cp866)],
  33         7 => [qw(iso-8859-7 cp1253 MacGreek cp737 cp869)],
  34         8 => [qw(iso-8859-8 cp1255 MacHebrew cp862)],
  35 );
  36 my @request = map {
  37         if (my $input = $_) {
  38                 my %row = (offset => 0);
  39                 my $endpoint = 255;
  40                 if ($input =~ s/^--//) {
  41                         $row{offset} = $endpoint > 160 ? 160 : 48;
  42                 }
  43                 elsif ($input =~ s/^-//) {
  44                         $row{offset} = $endpoint > 128 ? 128 : 32;
  45                 }
  46                 if ($input =~ s/-$//) {
  47                         $endpoint = $row{offset} ? $row{offset} < 160 ? 159 : 191 : 127;
  48                 }
  49
  50                 if ($input =~ /^U([0-9a-f]+)(?:-([0-9a-f]+))?/) {
  51                         my $start = hex($1) << ($2 ? 4 : 8);
  52                         my $end = $2 ? hex($2) << 4 : $start + 240;
  53                         $row{table} = join '', map { chr } $start .. $end+15;
  54                         utf8::upgrade($row{table});  # prevent latin1 output
  55                         $row{set} = sprintf 'Unicode block U+%02Xxx', $start >> 8;
  56                 }
  57                 elsif ($input eq 'U') {
  58                         $row{table} = ' ' x 512;
  59                         $row{set} = 'Unicode planes';
  60                         $row{cell} = do 'charset-ucplanes.inc.pl';
  61                 }
  62                 elsif ($row{set} = resolve_alias($input)) {
  63                         if ($row{set} eq 'Internal') {
  64                                 $row{table} = ' ' x ($endpoint < 255 ? 640 : 4096);
  65                                 $row{set} = 'Unicode BMP';
  66                                 $row{cell} = do 'charset-unicode.inc.pl';
  67                         }
  68                         elsif ($row{set} eq 'utf-8-strict') {
  69                                 $row{table} = undef;
  70                                 $row{set} = 'UTF-8';
  71                                 $row{cell} = do 'charset-utf8.inc.pl';
  72                         }
  73                         else {
  74                                 $row{table} = decode($row{set}, pack 'C*', $row{offset} .. $endpoint);
  75                         }
  76                 }
  77                 else {
  78                         print "<p>Encoding $input unknown</p>\n";
  79                 }
  80                 \%row;
  81         }
  82         else {
  83                 ();
  84         }
  85 } map { defined $ALIAS{$_} ? @{ $ALIAS{$_} } : $_ }
  86         $ENV{PATH_INFO} =~ /\w/ ? split(m{[/+\s]}, $ENV{PATH_INFO}) : 'default';
  87 my $NOCHAR = chr 0xFFFD;
  88
  89 for my $cp437 (grep {$request[$_]->{set} eq 'cp437'} 0 .. $#request) {
  90         substr($request[$cp437]->{table}, 237, 1) = pack 'U*', 0x3D5; # phi sign
  91         substr($request[$cp437]->{table}, 0, 32) = pack 'U*', map {hex} qw(
  92                 2007 263A 263B 2665 2666 2663 2660 2022 25D8 25CB 25D9 2642 2640 266A 266B 263C
  93                 25BA 25C4 2195 203C 00B6 00A7 25AC 21A8 2191 2193 2192 2190 221F 2194 25B2 25BC
  94         );
  95 }
  96
  97 my @nibble = (0..9, 'A'..'F');
  98 for my $row (@request) {
  99         printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
 100         printf '<caption>%s</caption>', $row->{set};
 101         print '<col>' x 17;
 102         for my $section (qw{thead}) {
 103                 print "<$section><tr><th>↱";
 104                 print '<th>', $_ for @nibble;
 105                 print "\n";
 106         }
 107         print '<tbody>';
 108         for my $msb (0 .. (length($row->{table}) || 256) - 1 >> 4) {
 109                 printf '<tr><th>%X', $msb + ($row->{offset} >> 4);
 110                 for my $lsb (0 .. $#nibble) {
 111                         if ($row->{cell}) {
 112                                 print $row->{cell}->(($msb<<4) + $lsb);
 113                                 next;
 114                         }
 115
 116                         my $glyph = substr $row->{table}, ($msb<<4) + $lsb, 1;
 117                         if ($glyph eq $NOCHAR) {
 118                                 print '<td>';
 119                                 next;
 120                         }
 121
 122                         my $info = [ord $glyph];
 123                         if (defined (my $mnem = $di{ord $glyph})) {
 124                                 $info = $diinfo->{$mnem};
 125                         }
 126                         else {
 127                                 require Unicode::UCD;
 128                                 my $fullinfo = Unicode::UCD::charinfo(ord $glyph);
 129                                 $info = [@$fullinfo{qw/code name category script string/}] if $fullinfo;
 130                         }
 131                         my ($codepoint, $name, $prop, $script, $string) = @$info;
 132
 133                         $glyph = EscapeHTML($string || $glyph);
 134                         my $desc = sprintf 'U+%04X%s', $codepoint, $name && " ($name)";
 135                         my @class = ('X', grep {$_} $prop, $script);
 136
 137                         $glyph = "<span>$glyph</span>" if $prop eq 'Zs';
 138
 139                         printf "\n".'<td class="%s" title="%s">%s',
 140                                 join(' ', @class), EscapeHTML($desc), $glyph;
 141                 }
 142                 print "\n";
 143         }
 144         print "</table></div>\n";
 145 }
 146
 147 :>
 148 <hr>
 149
 150 <div class="legend">
 151         <table class="glyphs"><tr>
 152         <td class="X Cc">control
 153         <td class="X Zs"><span>whitespace</span>
 154         <td class="X Mn">diacritic<table class="glyphs"><tr>
 155                 <td class="X Sk">letter
 156                 </table>
 157         <td class="X Po">punctuation<table class="glyphs"><tr>
 158                 <td class="X Pf">quote
 159                 </table>
 160         <td class="X So">symbol<table class="glyphs"><tr>
 161                 <td class="X Sm">math
 162                 <td class="X Sc">currency
 163                 </table>
 164         <td class="X No">numeric
 165         <td class="X Greek">greek<table class="glyphs"><tr>
 166                 <td class="X Latin">latin
 167                 <td class="X Cyrillic">cyrillic
 168                 </table>
 169         <td class="X Aramaic">aramaic<table class="glyphs"><tr>
 170                 <td class="X Brahmic">brahmic
 171                 <td class="X Arabic">arabic
 172                 </table>
 173         <td class="X Syllabic">syllabic<table class="glyphs"><tr>
 174                 <td class="X African">african
 175                 <td class="X Hiragana">japanese
 176                 <td class="X Han">cjk
 177                 <td class="X Bopomofo">chinese
 178                 </table>
 179         <td class="X Alpha">alphabetic
 180         </table>
 181
 182         <table class="glyphs"><tr>
 183         <td class="X">unicode 5.0
 184         <td class="X Xr">proposed
 185         <td class="X Xd">deprecated
 186         <td class="">unassigned
 187         <td class="X Xi">invalid
 188         </table>
 189 </div>
 190
 191 <p class="footer">
 192         <a href="/" rel="home">sheet.shiar.nl</a>/charset.<a href="/source/charset.plp"
 193          rel="code" title="Written in Perl">plp</a>
 194         <a href="http://git.shiar.nl/sheet.git/history/HEAD:/charset.plp"
 195          rel="vcs-git" title="Git repository"><:= $VERSION :></a>
 196         created by <a href="http://shiar.nl/" rel="author">Shiar</a> •
 197         <a href="http://www.fsf.org/licensing/licenses/agpl-3.0.html" rel="copyright"
 198          title="Licensed under the GNU Affero General Public License, version 3">AGPLv3</a>
 199 </p>
 200
 201 </html>