charset: configurable table inclusion

[sheet.git] / charset.plp

diff --git a/charset.plp b/charset.plp
index d3ddea72a4dc20d9dac554bef4e18132d874db95..e9c4fcc7c0d323f2b34895096ad73aacae08339a 100644 (file)
--- a/charset.plp
+++ b/charset.plp
@@ -26,13 +26,34 @@ my $diinfo = do 'digraphs.inc.pl';
 my %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} }
        keys %$diinfo;
 
-use Encode qw(decode);
+use Encode qw(decode resolve_alias);
 # generate character table(s)
 # (~16x faster than decoding in loop;
 #  substr strings is twice as fast as splitting to an array)
-my @tables = map { decode($_, pack 'C*', 0..255) } 'iso-8859-1';
+my %ALIAS = (
+       default => [qw(utf-8 iso-8859-1 cp437)],
+       0 => [qw(cp437 cp863)],
+       1 => [qw(iso-8859-1 cp1252 MacRoman cp850)],
+       2 => [qw(iso-8859-2 cp1250 cp852 MacCentralEurRoman MacCroatian MacRumanian)],
+       5 => [qw(koi8-f iso-8859-5 cp1251 MacCyrillic cp855 cp866)],
+       7 => [qw(iso-8859-7 cp1253 MacGreek cp737 cp869)],
+       8 => [qw(iso-8859-8 cp1255 MacHebrew cp862)],
+);
+my @request = grep { defined } map {
+       $_ ? (resolve_alias($_) or print("Encoding $_ unknown") && ()) : ();
+} map { defined $ALIAS{$_} ? @{ $ALIAS{$_} } : $_ }
+       $ENV{PATH_INFO} =~ /\w/ ? split(m{[/+\s]}, $ENV{PATH_INFO}) : 'default';
+my @tables = map { $_ eq 'utf-8-strict' ? undef : decode($_, pack 'C*', 0..255) } @request;
 my $NOCHAR = chr 0xFFFD;
 
+for my $cp437 (grep {$request[$_] eq 'cp437'} 0 .. $#request) {
+       substr($tables[$cp437], 237, 1) = pack 'U*', 0x3D5; # phi sign
+       substr($tables[$cp437], 0, 32) = pack 'U*', map {hex} qw(
+               2007 263A 263B 2665 2666 2663 2660 2022 25D8 25CB 25D9 2642 2640 266A 266B 263C
+               25BA 25C4 2195 203C 00B6 00A7 25AC 21A8 2191 2193 2192 2190 221F 2194 25B2 25BC
+       );
+}
+
 sub quote {
        local $_ = shift;
        s/"/"/g;
@@ -41,19 +62,87 @@ sub quote {
        return $_;
 }
 
+sub printcell_utf8 {
+       my ($value) = @_;
+       if ($value <= 0x7F) {
+               print '<td rowspan="8" colspan="16" class="X di-a"',
+                         ' title="U+0000 – U+007F">Single byte ASCII'
+                       if $value == 0;
+       }
+       elsif ($value <= 0xBF) {
+               print '<td rowspan="4" colspan="16" class="X di-d"',
+                         '>Multi-byte continuation'
+                       if $value == 0x80;
+       }
+       elsif ($value <= 0xC1) {
+               print '<td colspan="2" class="X di-b" style="border-right:none; border-bottom:none"',
+                         ' title="U+0000 – U+007F">(Overl.)'
+                       if $value == 0xC0;
+       }
+       elsif ($value <= 0xDF) {
+               print '<td rowspan="2" colspan="14" class="X di-prop" style="border-left:none"',
+                         ' title="U+0080 – U+03FF">2-byte sequence start'
+                       if $value == 0xC2;
+               print '<td rowspan="1" colspan="16" class="X di-prop" style="border-top:none"',
+                         ' title="U+0400 – U+07FF">'
+                       if $value == 0xD0;
+       }
+       elsif ($value <= 0xEF) {
+               print '<td colspan="16" class="X di-prop"',
+                         ' title="U+0800 – U+FFFF">3-byte sequence start'
+                       if $value == 0xE0;
+       }
+       elsif ($value <= 0xF4) {
+               print '<td colspan="5" class="X di-prop" style="border-right:none"',
+                         ' title="U+1·0000 – U+10·FFFF">4-byte sequence'
+                       if $value == 0xF0;
+       }
+       elsif ($value <= 0xF7) {
+               print '<td colspan="3" class="X di-b" style="border-left:none"',
+                         ' title="U+11·0000 – U+1FF·FFFF">(Overflow)'
+                       if $value == 0xF5;
+       }
+       elsif ($value <= 0xFB) {
+               print '<td colspan="4" class="X di-b"',
+                         ' title="U+200·0000 – U+3FFF·FFFF">5-byte'
+                       if $value == 0xF8;
+       }
+       elsif ($value <= 0xFD) {
+               print '<td colspan="2" class="X di-b"',
+                         ' title="U+4000·0000 – 7FFFF·FFFF">6-byte'
+                       if $value == 0xFC;
+       }
+       elsif ($value <= 0xFF) {
+               print '<td colspan="2" class="di-invalid">Invalid'
+                       if $value == 0xFE;
+       }
+       else {
+               print "\n".'<td class="X">?';
+       }
+}
+
+print "<ul>\n";
+
 my @nibble = (0..9, 'A'..'F');
-for my $table (@tables) {
-       print '<table class="glyphs"><col>';
-       for my $section (qw{thead tfoot}) {
-               print "<$section><tr><th>↳";
+for my $tablenum (0 .. $#tables) {
+       print '<li><table class="glyphs">';
+       printf '<caption>%s</caption>', $request[$tablenum] eq 'utf-8-strict' ? 'UTF-8' : $request[$tablenum];
+       print '<col>';
+       for my $section (qw{thead}) {
+               print "<$section><tr><th>↱";
                print '<th>', $_ for @nibble;
-               print "<th>&nbsp;\n";
+               print "\n";
        }
        print '<tbody>';
        for my $msb (0 .. $#nibble) {
                print '<tr><th>', $nibble[$msb];
                for my $lsb (0 .. $#nibble) {
-                       my $glyph = substr $table, ($msb<<4) + $lsb, 1;
+                       if ($request[$tablenum] eq 'utf-8-strict') {
+                               printcell_utf8(($msb<<4) + $lsb);
+                               next;
+                       }
+
+                       my $glyph = substr $tables[$tablenum], ($msb<<4) + $lsb, 1;
                        if ($glyph eq $NOCHAR) {
                                print '<td>';
                                next;
@@ -73,8 +162,26 @@ for my $table (@tables) {
                        printf "\n".'<td class="%s" title="%s">%s',
                                join(' ', @class), quote($desc), $glyph;
                }
-               print "\n<th>", $nibble[$msb], "\n";
+               print "\n";
        }
        print "</table>\n";
 }
 
+print "</ul>\n";
+
+:>
+<hr>
+
+<p class="footer">
+       <a href="http://sheet.shiar.nl/" rel="home">sheet.shiar.nl</a>/charset
+       <a href="git://git.shiar.nl/sheet" rel="vcs-git" title="Git repository"><:= "v$VERSION" :></a>
+       created by <a href="http://shiar.nl/" rel="author">Shiar</a> •
+       <a title="Licensed under the GNU Affero General Public License, version 3" rel="copyright"
+          href="http://www.fsf.org/licensing/licenses/agpl-3.0.html">AGPLv3</a> •
+       last update <:
+               use Time::Format qw(time_format);
+               print time_format('yyyy-mm-dd', (stat $ENV{SCRIPT_FILENAME})[9]);
+       :>
+</p>
+
+</html>