X-Git-Url: http://git.shiar.nl/sheet.git/blobdiff_plain/0e07efe0549f928d061f52c16ed9a4ee8260b49a..1d6eab5fa03b9b245c50637bae352344f9f53ef5:/charset.plp diff --git a/charset.plp b/charset.plp index d2c92c5..0dd1537 100644 --- a/charset.plp +++ b/charset.plp @@ -5,7 +5,7 @@ my @tablist = split m{/+}, $Request || 'default'; Html({ title => 'charset cheat sheet', - version => '1.0', + version => '1.1', description => [ "Reference sheet with all glyphs in common character encoding tables,", "and an overview of Unicode ranges and UTF-8 bytes.", @@ -36,18 +36,10 @@ else { say "Charset comparison:"; } -sub optionlink { - my ($title, $href, $selected) = @_; - return sprintf( - $selected ? '%s' : '%s', - EscapeHTML($title), $href - ); -} - print join " •\n", ( map { join " ·\n", pairmap { - optionlink($b || ucfirst $a, '/charset'.($a && "/$a?compare"), $a eq $Request); + showlink($b || ucfirst $a, '/charset'.($a && "/$a?compare"), $a eq $Request); } @{$_} } [ @@ -83,61 +75,21 @@ my $charsets = do 'charset-encoding.inc.pl' sub tabinput { # generate character table(s) my $input = shift or return; + my $params = $input =~ s/[+](.*)\z// ? $1 : undef; + my $charset = $charsets->{lc $input} || {}; - state $ALIAS = { - default => [qw( u+0-27F utf-8+realsize iso-8859-1 iso-8859-15 cp1252 cp437 cp850 )], - unicode => [qw( uu+cols=32+realsize u+0-FFF u+1000-18AF u+18B0-1FFF )], - us => [qw( cp437 cp863 gsm0338 AdobeStandardEncoding )], - ebcdic => [qw( cp37 cp500 cp1047 posix-bc cp1026 cp875 )], - iso => [map {"iso-8859-$_"} 1 .. 11, 13 .. 16], - dos => [qw( cp437 cp865 cp861 cp860 cp863 cp850 cp857 cp852 cp775 - cp737 cp869 cp866 cp855 cp862 cp864 )], - aix => [qw( cp1006 )], - win => [qw( cp1252 cp1250 cp1254 cp1257 cp1258 cp1253 cp1251 cp1255 cp1256 cp874 )], - mac => [qw( MacRoman MacRomanian MacRumanian MacCroatian MacCentralEurRoman MacTurkish MacIcelandic MacSami - MacGreek MacCyrillic MacHebrew MacArabic MacFarsi MacThai )], - - # languages - westeur => [qw( iso-8859-1 iso-8859-15 cp1252 iso-8859-14 cp850 hp-roman8 nextstep MacRoman )], - centeur => [qw( iso-8859-2 iso-8859-16 cp1250 cp852 MacRomanian MacCroatian MacCentralEurRoman )], # MacRumanian only for DB - turkish => [qw( iso-8859-9 iso-8859-3 cp1254 cp857 MacTurkish )], - norteur => [qw( baltic nordic )], - baltic => [qw( iso-8859-4 iso-8859-13 cp1257 cp775 )], - nordic => [qw( iso-8859-10 cp865 cp861 MacIcelandic MacSami )], - cyrillic => [qw( koi8-r koi8-u koi8-f iso-8859-5 cp1251 MacCyrillic cp866 cp855 - +400 +2DE0 +A640-A69F +500-52F )], # MacUkrainian is broken - arabic => [qw( iso-8859-6 cp1256 MacArabic cp864 cp1006 MacFarsi - +600 +8A0-8BF+8E0 +750-77F )], - greek => [qw( iso-8859-7 cp1253 MacGreek cp737 cp869 +370 +1F00 )], - hebrew => [qw( iso-8859-8 cp1255 MacHebrew cp862 +590 )], - thai => [qw( iso-8859-11 cp874 MacThai )], - vietnamese => [qw( viscii cp1258 MacVietnamese )], - symbols => [qw( symbol dingbats MacDingbats wingdings wingdings2 wingdings3 webdings )], - - # iso-code shorthand - 1 => 'westeur', - 2 => 'centeur', - 3 => 'turkish', - 4 => 'baltic', - 5 => 'cyrillic', - 6 => 'arabic', - 7 => 'greek', - 8 => 'hebrew', - 9 => 'turkish', - 10 => 'nordic', - 11 => 'thai', - }; - if (my $follow = $ALIAS->{$input}) { - tabinput($_) for ref $follow ? @{$follow} : $follow; + if (ref $charset ne 'HASH') { + $params and Alert("Parameters ignored for $input", + "Cannot apply $params to multiple charsets.", + ); + tabinput($_) for ref $charset ? @{$charset} : $charset; return; } state $visible = {'' => 1}; # all present tables my %row = (offset => 0, cols => 16); - my $params = $input =~ s/[+](.*)\z// ? $1 : undef; if (not defined $params) { - my $charset = $charsets->{$input} || {}; my @parents = @{ $charset->{inherit} || [] }; if (my ($parent, $part) = pairfirst { defined $visible->{$a} } @parents) { @@ -183,54 +135,18 @@ sub tabinput { } } - if ($input =~ m{ \A (?:wing|web)dings \d* \z }ix) { - eval "require Encode::\u$input"; + if ($charset->{setup}) { + eval { $charset->{setup}->(\%row) } + or Alert("Incomplete setup of $input", $@); } + $row{endpoint} ||= 0xFF; - if ($input eq '') { - $row{offset} = delete $row{startpoint}; - $row{set} = 'Unicode characters'; - my $block = $row{offset} >> 8; - $row{endpoint} ||= ($block + 1 << 8) - 1; - $block == ($row{endpoint} >> 8) or undef $block; - - $row{table} = join '', map { chr } $row{offset} .. $row{endpoint}; - utf8::upgrade($row{table}); # prevent latin1 output - - $row{endpoint} -= $row{offset}; - - if (defined $block) { - $row{set} = sprintf 'Unicode block U+%02Xxx', $block; - $row{offset} %= 0x100; - } - } - elsif (lc $input eq 'uu') { - $row{cell} = do 'charset-ucplanes.inc.pl' - or Alert('Table data could not be read', $@ || $!); - $row{endpoint} ||= 0x3FF; - $row{set} = 'Unicode planes'; - } - elsif (lc $input eq 'u') { - $row{cell} = do 'charset-unicode.inc.pl' - or Alert('Table data could not be read', $@ || $!); - - $row{endpoint} ||= 0x1FFF; - $row{set} = 'Unicode ' . ( - $row{startpoint} < 0x1000 && $row{endpoint} < 0x1000 ? 'BMP' : - $row{startpoint} >= 0x1000 && $row{endpoint} < 0x2000 ? 'SMP' : - 'allocations' - ); - } - elsif ($input =~ m/^utf-*8$/i) { - $row{set} = 'UTF-8'; - $row{cell} = do 'charset-utf8.inc.pl' - or Alert('Table data could not be read', $@ || $!); - $row{endpoint} = 0xFF; + if (defined $row{table} or defined $row{cell}) { + $row{set} //= $input; } elsif ($row{set} = Encode::resolve_alias($input)) { $row{offset} = delete $row{startpoint}; - $row{endpoint} ||= 0xFF; - if ($row{set} eq 'MacHebrew' or $row{set} eq 'MacThai') { + if ($charset->{varchar}) { # array of possibly multiple characters per code point $row{table} = [ map { Encode::decode($row{set}, pack 'C*', $_) } $row{offset} .. $row{endpoint} @@ -242,43 +158,47 @@ sub tabinput { $row{table} = Encode::decode($row{set}, pack 'C*', $row{offset} .. $row{endpoint}); } - if ($row{set} eq 'cp437') { - if ($row{offset} <= 0xED and $row{endpoint} >= 0xED) { - # replace phi glyph - substr($row{table}, 0xED - $row{offset}, 1) = 'ϕ'; - } - if ($row{offset} < 0x20) { - # replace control characters by visible variants - my $sub = substr ' ☺☻♥♦♣♠•◘○◙♂♀♪♫☼►◄↕‼¶§▬↨↑↓→←∟↔▲▼', $row{offset}; - substr($row{table}, 0, length $sub) = $sub; - } - } - elsif ($row{set} eq 'symbol') { - if ($row{offset} <= 0x60 and $row{endpoint} >= 0x60) { - # replace radical extender by closest unicode equivalent - substr($row{table}, 0x60 - $row{offset}, 1) = '│'; - } - if ($row{offset} <= 0xBD and $row{endpoint} >= 0xFF) { - substr($row{table}, 0xBD - $row{offset}, 2) = '⏐⎯'; # arrow extenders - substr($row{table}, 0xD2 - $row{offset}, 3) = '®©™'; # serif variants - substr($row{table}, 0xE0 - $row{offset}, 1) = '◊'; # replace lookalike, should match AdobeSymbol - substr($row{table}, 0xE2 - $row{offset}, 3) = '®©™'; # sans-serif variants - substr($row{table}, 0xE6 - $row{offset}, 10) = '⎛⎜⎝⎡⎢⎣⎧⎨⎩⎪'; - substr($row{table}, 0xF0 - $row{offset}, 1) = '€'; - substr($row{table}, 0xF4 - $row{offset}, 11) = '⎮⌡⎞⎟⎠⎤⎥⎦⎫⎬⎭'; - } - } - $row{endpoint} -= $row{offset}; - - $visible->{ascii} = # assume common base - $visible->{ $row{set} } = 1; + $visible->{ascii}++; # assume common base } else { Alert("Encoding $input unknown"); return; } + + if (my $replace = $charset->{replace}) { + while (my ($offset, $sub) = each %{$replace}) { + $offset -= $row{offset}; + + if (ref $row{table} eq 'ARRAY') { + $row{table}->[$offset] = $sub + if $offset >= 0 and $offset <= $row{endpoint}; + next; + } + + my $length = length $sub; + + if ($offset < 0) { + $offset > -$length or next; # at least one character after start + # trim leftmost part to start at offset + substr($sub, 0, -$offset) = ''; + $length += $offset; + $offset = 0; + } + + if ((my $excess = $row{endpoint} - $offset - $length + 1) < 0) { + $excess > -$length or next; + # trim rightmost part to prevent overflow + substr($sub, $excess) = ''; + $length += $excess; + } + + substr($row{table}, $offset, $length) = $sub; + } + } + push @request, \%row; + $visible->{ $row{set} } = 1 if $row{table}; } tabinput($_) for @tablist; @@ -402,7 +322,7 @@ for my $row (@request) { my $cp = $offset + $row->{offset}; my $glyph = ref $row->{table} eq 'ARRAY' ? $row->{table}->[$offset] : substr $row->{table}, $offset, 1; - my ($cell, $name, $class) = $glyph eq $NOCHAR ? () : + my ($cell, $name, $class) = !defined $glyph || $glyph eq $NOCHAR ? () : $glyphs->glyph_html($glyph); if ($mode) {