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 (file)
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 = "<span>$cell</span>" if $prop eq 'Zs';
+       $cell = '&nbsp;' 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('<td class="%3$s" title="%2$s">%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('<td%s%s%s>%s%s',
+               defined $title  ? qq{ title="$title"}  : '',
+               @class ? sprintf(' class="%s"', join ' ', @class) : '',
+               $html || '',
+               $cell eq '' ? '&nbsp;' : $cell,
+               defined $mnem && length $mnem
+                       ? sprintf(' <small class="digraph">%s</small>', EscapeHTML($mnem))
+                       : $cell =~ /^[^a-zA-Z]$/
+                               ? sprintf(' <small class="%s">%04X</small>', '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 '_' ? '&nbsp;' : $cell
+               );
+       }
+       push @rows, sprintf '<thead><tr>%s<tbody>', 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] .= '<th>'.($cell || '&nbsp;');
+                       }
+                       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{<table class="glyphs dilabel">\n%s</table>\n},
+               join '', map {"<tr>$_\n"} @rows;
+}
+
+1;
+

diff --git a/charset.plp b/charset.plp
index e2b2e277725fa1bd6204c87d962880f7a88ffde9..e5fdd45966452046996d6e398e5611e499f9022e 100644 (file)
--- a/charset.plp
+++ b/charset.plp
@@ -18,9 +18,8 @@ Html({
 <h1>Character encoding</h1>
 
 <:
-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 = "<span>$glyph</span>" if $prop eq 'Zs';
-
-                       printf "\n".'<td class="%s" title="%s">%s',
-                               join(' ', @class), EscapeHTML($desc), $glyph;
+                       print "\n".$glyphs->glyph_cell($glyph);
                }
                print "\n";
        }

diff --git a/unicode.plp b/unicode.plp
index 3435730b1bb23a16fbe9f17513eb813be7566794..f558448caad6cfa7a8a618b696f09ed5562f6ab3 100644 (file)
--- a/unicode.plp
+++ b/unicode.plp
@@ -22,105 +22,14 @@ Also see the <a href="/digraphs">complete digraphs table</a>.</p>
 <div class="diinfo">
 
 <:
-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 '_' ? '&nbsp;' : $cell
-               );
-       }
-       push @rows, sprintf '<thead><tr>%s<tbody>', 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] .= '<th>'.($cell || '&nbsp;');
-                       }
-                       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('<td%s%s%s>%s%s',
-                       defined $name  ? qq{ title="$name"}  : '',
-                       @class ? sprintf(' class="%s"', join ' ', @class) : '',
-                       $colspan > 1 && qq{ colspan="$colspan"},
-                       $cell eq '' ? '&nbsp;' : EscapeHTML($cell),
-                       defined $code ? sprintf(' <small class="digraph">%s</small>', EscapeHTML($code))
-                               : length($cell) == 1 && $cell !~ /[a-z]/
-                                       ? sprintf(' <small class="%s">%04X</small>', 'value', ord $cell)
-                                       : '',
-               );
-
-               $colspan = 1;
-       }
-
-       return sprintf qq{<table class="glyphs dilabel">\n%s</table>\n},
-               join '', map {"<tr>$_\n"} @rows;
-}
+use Shiar_Sheet::FormatChar;
+my $glyphs = Shiar_Sheet::FormatChar->new;
 
 sub print_glyph_tables {
        while (@_) {
                printf '<div class="section"><h2>%s</h2>'."\n\n", shift;
                while (ref $_[0] and $_ = shift) {
-                       print glyph_table($_);
+                       print $glyphs->table($_);
                }
                print '</div>';
        }