From: Mischa POSLAWSKY Date: Tue, 23 Feb 2010 01:20:46 +0000 (+0000) Subject: common module FormatChar to show character tables X-Git-Tag: v1.3~58 X-Git-Url: http://git.shiar.nl/sheet.git/commitdiff_plain/378d119f5791fea807f36749ce9ecb5a5c60952e common module FormatChar to show character tables Equivalent to code moved from unicode.plp, and a superset of charset.plp. To be used in upcoming pages. --- diff --git a/Shiar_Sheet/FormatChar.pm b/Shiar_Sheet/FormatChar.pm new file mode 100644 index 0000000..a501b94 --- /dev/null +++ b/Shiar_Sheet/FormatChar.pm @@ -0,0 +1,159 @@ +package Shiar_Sheet::FormatChar; + +use strict; +use warnings; + +use Data::Dump 'pp'; +use PLP::Functions 'EscapeHTML'; + +our $VERSION = '1.00'; + +our $diinfo = do 'digraphs.inc.pl'; +our %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} } + sort { length $a <=> length $b } keys %$diinfo; + +sub new { + my ($class) = @_; + bless {}, $class; +} + +sub glyph_info { + my ($self, $codepoint) = @_; + if (defined (my $mnem = $di{$codepoint})) { + return ($diinfo->{$mnem}, length $mnem == 2 ? $mnem : undef); + } + require Unicode::UCD; + if (my $fullinfo = Unicode::UCD::charinfo($codepoint)) { + return [$codepoint, @$fullinfo{qw/name category script string/}]; + } + return [$codepoint]; +} + +sub glyph_html { + my ($self, $char) = @_; + my ($info, $mnem) = $self->glyph_info(ord $char); + my ($codepoint, $name, $prop, $script, $string) = @$info; + + my $cell = EscapeHTML($string || $char); + my $title = sprintf 'U+%04X%s', $codepoint, $name && " ($name)"; + my @class = ('X', grep {$_} $prop, $script); + + $cell = "$cell" if $prop eq 'Zs'; + $cell = ' ' if $cell eq ''; + + return ($cell, EscapeHTML($title), join(' ', @class), $mnem); +} + +sub glyphs_html { + my $self = shift; + + return $self->glyph_html(@_) if length $_[0] <= 1; + + my @chars = map { [ $self->glyph_html($_) ] } split //, $_[0]; + return ( + EscapeHTML($_[0]), # cell + join(' | ', map { $_->[1] } @chars), # title + $chars[0][2], # class + join(' ', grep { defined } map { $_->[3] } @chars), # digraph + ); +} + +sub glyph_cell { + my ($self, $char) = @_; + return sprintf('%s', $self->glyph_html($char)); +} + +sub cell { + my ($self, $input, $html) = @_; + my (@class, $title, $cell, $mnem); + + if ($input eq '-') { + $cell = ''; + } + elsif ($input eq '=') { + push @class, 'di-invalid'; + $cell = ''; + } + else { + push @class, 'X'; + + if ($input =~ s/^-//) { + push @class, 'di-rare'; # discouraged + } + + ($cell, $title, my $class, $mnem) = $self->glyphs_html($input); + + if (defined $mnem) { + push @class, 'di-d'; # digraph + push @class, 'di-prop' if $class =~ /\bXz\b/; # unofficial + } + + if ($input =~ /[ -~]/) { + push @class, 'di-a'; # ascii + } + else { + push @class, 'di-b'; # basic unicode + } + } + + return sprintf('%s%s', + defined $title ? qq{ title="$title"} : '', + @class ? sprintf(' class="%s"', join ' ', @class) : '', + $html || '', + $cell eq '' ? ' ' : $cell, + defined $mnem && length $mnem + ? sprintf(' %s', EscapeHTML($mnem)) + : $cell =~ /^[^a-zA-Z]$/ + ? sprintf(' %04X', 'value', ord $cell) + : '', + ); +} + +sub table { + my ($self, $digraphs) = @_; + + my @rows; + + my @colheads; + while ($digraphs->[0] !~ /^\./) { + my $cell = shift @$digraphs or last; + push @colheads, sprintf( + '<%s%s>%s', + $cell =~ s/^-// ? 'td' : 'th', + $cell =~ s/:(.*)// ? qq{ title="$1"} : '', + $cell eq '_' ? ' ' : $cell + ); + } + push @rows, sprintf '%s', join '', @colheads if @colheads; + + my $colspan = 1; + for my $cell (@$digraphs) { + if ($cell =~ s/^\.//) { + # dot indicates start of a new row + push @rows, ''; + if ($cell =~ s/^>//) { + # header cell text follows + $cell =~ s/_/ /g; # underscores may be used instead of whitespace (for qw//ability) + $rows[-1] .= ''.($cell || ' '); + } + next; + } + elsif ($cell eq '>') { + # merge this cell to the next column + $colspan++; + next; + } + + $rows[-1] .= $self->cell($cell, + $colspan > 1 && qq{ colspan="$colspan"}, + ); + + $colspan = 1; + } + + return sprintf qq{\n%s
\n}, + join '', map {"$_\n"} @rows; +} + +1; + diff --git a/charset.plp b/charset.plp index e2b2e27..e5fdd45 100644 --- a/charset.plp +++ b/charset.plp @@ -18,9 +18,8 @@ Html({

Character encoding

<: -my $diinfo = do 'digraphs.inc.pl'; -my %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} } - keys %$diinfo; +use Shiar_Sheet::FormatChar; +my $glyphs = Shiar_Sheet::FormatChar->new; use Encode qw(decode resolve_alias); # generate character table(s) @@ -122,25 +121,7 @@ for my $row (@request) { next; } - my $info = [ord $glyph]; - if (defined (my $mnem = $di{ord $glyph})) { - $info = $diinfo->{$mnem}; - } - else { - require Unicode::UCD; - my $fullinfo = Unicode::UCD::charinfo(ord $glyph); - $info = [@$fullinfo{qw/code name category script string/}] if $fullinfo; - } - my ($codepoint, $name, $prop, $script, $string) = @$info; - - $glyph = EscapeHTML($string || $glyph); - my $desc = sprintf 'U+%04X%s', $codepoint, $name && " ($name)"; - my @class = ('X', grep {$_} $prop, $script); - - $glyph = "$glyph" if $prop eq 'Zs'; - - printf "\n".'%s', - join(' ', @class), EscapeHTML($desc), $glyph; + print "\n".$glyphs->glyph_cell($glyph); } print "\n"; } diff --git a/unicode.plp b/unicode.plp index 3435730..f558448 100644 --- a/unicode.plp +++ b/unicode.plp @@ -22,105 +22,14 @@ Also see the complete digraphs table.

<: -my $diinfo = do 'digraphs.inc.pl'; -my %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} } - sort { length $a <=> length $b } keys %$diinfo; - -sub glyph_table { - my ($digraphs) = @_; - - my @rows; - - my @colheads; - while ($digraphs->[0] !~ /^\./) { - my $cell = shift @$digraphs or last; - push @colheads, sprintf( - '<%s%s>%s', - $cell =~ s/^-// ? 'td' : 'th', - $cell =~ s/:(.*)// ? qq{ title="$1"} : '', - $cell eq '_' ? ' ' : $cell - ); - } - push @rows, sprintf '%s', join '', @colheads if @colheads; - - my $colspan = 1; - for my $cell (@$digraphs) { - if ($cell =~ s/^\.//) { - # dot indicates start of a new row - push @rows, ''; - if ($cell =~ s/^>//) { - # header cell text follows - $cell =~ s/_/ /g; # underscores may be used instead of whitespace (for qw//ability) - $rows[-1] .= ''.($cell || ' '); - } - next; - } - elsif ($cell eq '>') { - # merge this cell to the next column - $colspan++; - next; - } - - my ($code, $name); - - # determine display class - my @class; - if ($cell eq '-') { - $cell = ''; - } - elsif ($cell eq '=') { - push @class, 'di-invalid'; - $cell = ''; - } - else { - push @class, 'X'; - - if ($cell =~ s/^-//) { - push @class, 'di-rare'; # discouraged - } - - $code = join '', map { $di{ord $_} || '' } split //, $cell; - $name = $diinfo->{$code}->[1]; - length $code == 2 or undef $code; - - if (defined $code) { - push @class, 'di-d'; # digraph - push @class, 'di-prop' # unofficial - if $diinfo->{$code}->[2] =~ /\bXz\b/; - } - - if ($cell =~ /[ -~]/) { - push @class, 'di-a'; # ascii - } - else { - push @class, 'di-b'; # basic unicode - } - } - - # add cell html - $rows[-1] .= sprintf('%s%s', - defined $name ? qq{ title="$name"} : '', - @class ? sprintf(' class="%s"', join ' ', @class) : '', - $colspan > 1 && qq{ colspan="$colspan"}, - $cell eq '' ? ' ' : EscapeHTML($cell), - defined $code ? sprintf(' %s', EscapeHTML($code)) - : length($cell) == 1 && $cell !~ /[a-z]/ - ? sprintf(' %04X', 'value', ord $cell) - : '', - ); - - $colspan = 1; - } - - return sprintf qq{\n%s
\n}, - join '', map {"$_\n"} @rows; -} +use Shiar_Sheet::FormatChar; +my $glyphs = Shiar_Sheet::FormatChar->new; sub print_glyph_tables { while (@_) { printf '

%s

'."\n\n", shift; while (ref $_[0] and $_ = shift) { - print glyph_table($_); + print $glyphs->table($_); } print '
'; }