Shiar_Sheet/FormatChar.pm

   1 package Shiar_Sheet::FormatChar;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dump 'pp';
   7 use PLP::Functions 'EscapeHTML';
   8
   9 our $VERSION = '1.04';
  10
  11 our $diinfo = do 'digraphs.inc.pl';
  12 our %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} }
  13         sort { length $a <=> length $b } keys %$diinfo;
  14
  15 sub new {
  16         my ($class) = @_;
  17         bless { anno => ['di', 0], style => 'di' }, $class;
  18 }
  19
  20 sub glyph_info {
  21         my ($self, $codepoint) = @_;
  22         if (defined (my $mnem = $di{$codepoint})) {
  23                 return ($diinfo->{$mnem}, length $mnem == 2 ? $mnem : undef);
  24         }
  25         require Unicode::UCD;
  26         if (my $fullinfo = Unicode::UCD::charinfo($codepoint)) {
  27                 return [$codepoint, @$fullinfo{qw/name category script string/}];
  28         }
  29         return [$codepoint];
  30 }
  31
  32 sub glyph_html {
  33         my ($self, $char) = @_;
  34         my ($info, $mnem) = $self->glyph_info(ord $char);
  35         my ($codepoint, $name, $prop, $script, $string) = @$info;
  36
  37         my $cell = EscapeHTML($string || $char);
  38         my $title = sprintf 'U+%04X%s', $codepoint, $name && " ($name)";
  39         my @class = ('X', grep {$_} $prop, $script);
  40
  41         $cell = "<span>$cell</span>" if $prop and $prop eq 'Zs';
  42         $cell = '&nbsp;' if $cell eq '';
  43
  44         return ($cell, EscapeHTML($title), join(' ', @class), $mnem);
  45 }
  46
  47 sub glyphs_html {
  48         my $self = shift;
  49
  50         return $self->glyph_html(@_) if length $_[0] <= 1;
  51
  52         my @chars = map { [ $self->glyph_html($_) ] } split //, $_[0];
  53         return (
  54                 EscapeHTML($_[0]), # cell
  55                 join(' | ', map { $_->[1] } @chars), # title
  56                 $chars[0][2], # class
  57                 join(' ',  grep { defined } map { $_->[3] } @chars), # digraph
  58         );
  59 }
  60
  61 sub glyph_cell {
  62         my ($self, $char) = @_;
  63         return sprintf('<td class="%3$s" title="%2$s">%s', $self->glyph_html($char));
  64 }
  65
  66 sub cell {
  67         my ($self, $input, $html) = @_;
  68         my (@class, $title, $cell, $mnem);
  69
  70         if ($input eq '-') {
  71                 $cell = '';
  72         }
  73         elsif ($input eq '=') {
  74                 push @class, 'u-invalid';
  75                 $cell = '';
  76         }
  77         else {
  78                 push @class, 'X';
  79
  80                 if ($input =~ s/^-//) {
  81                         push @class, 'ex'; # discouraged
  82                 }
  83
  84                 $input =~ s/^\\//;  # escaped char
  85                 ($cell, $title, my $class, $mnem) = $self->glyphs_html($input);
  86
  87                 if ($self->{style} = 'di') {
  88                         if (defined $mnem) {
  89                                 push @class, $class =~ /\bXz\b/ ? ('l2', 'u-prop') # unofficial
  90                                         : ('l3', 'u-di'); # standard digraph
  91                         }
  92                 }
  93                 else {
  94                         my $codepoint = ord(substr $input, 0, 1);
  95                         if ($codepoint <= 0xFF) {
  96                                 push @class, 'l3', 'u-lat1';  # latin1
  97                         }
  98                         elsif ($codepoint <= 0xD7FF) {
  99                                 push @class, 'l2', 'u-bmp';  # bmp
 100                         }
 101                 }
 102
 103                 if ($input =~ /[ -~]/) {
 104                         push @class, 'l4', 'u-ascii'; # ascii
 105                 }
 106                 else {
 107                         push @class, 'l1'; # basic unicode
 108                 }
 109         }
 110
 111         my $anno = '';
 112         if ($cell ne '') {
 113                 for (@{ $self->{anno} }) {
 114                         if (/html$/) {
 115                                 require HTML::Entities;
 116                                 if (my $entity = $HTML::Entities::char2entity{$cell}) {
 117                                         $entity = substr($entity, 1, -1) unless /^&/;
 118                                         $anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($entity));
 119                                         last;
 120                                 }
 121                         }
 122                         elsif ($_ eq 'xml') {
 123                                 $anno = sprintf(' <small class="digraph">%s</small>',
 124                                         sprintf '#%d', ord($cell)
 125                                 );
 126                                 last;
 127                         }
 128                         elsif ($_ eq '&xml') {
 129                                 $anno = sprintf(' <small class="digraph">%s</small>',
 130                                         sprintf '&amp;#%d;', ord($cell)
 131                                 );
 132                                 last;
 133                         }
 134                         elsif ($_ eq 'di') {
 135                                 if (defined $mnem and length $mnem) {
 136                                         $anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($mnem));
 137                                         last;
 138                                 }
 139                         }
 140                         else {
 141                                 if ($_ eq 'hex' or $cell =~ /^[^a-zA-Z]$/) {
 142                                         $anno = sprintf(' <small class="%s">%04X</small>', 'value', ord $cell);
 143                                         last;
 144                                 }
 145                         }
 146                 }
 147         }
 148
 149         return sprintf('<td%s%s%s>%s%s',
 150                 defined $title  ? qq{ title="$title"}  : '',
 151                 @class ? sprintf(' class="%s"', join ' ', @class) : '',
 152                 $html || '',
 153                 $cell eq '' ? '&nbsp;' : $cell,
 154                 $anno,
 155         );
 156 }
 157
 158 sub table {
 159         my ($self, $digraphs) = @_;
 160
 161         my @rows;
 162
 163         my @colheads;
 164         while ($digraphs->[0] !~ /^\./) {
 165                 my $cell = shift @$digraphs or last;
 166                 push @colheads, sprintf(
 167                         '<%s%s>%s',
 168                         $cell =~ s/^-// ? 'td' : 'th',
 169                         $cell =~ s/:(.*)// ? qq{ title="$1"} : '',
 170                         $cell eq '_' ? '&nbsp;' : $cell
 171                 );
 172         }
 173         push @rows, sprintf '<thead><tr>%s<tbody>', join '', @colheads if @colheads;
 174
 175         my $colspan = 1;
 176         for my $cell (@$digraphs) {
 177                 if ($cell =~ s/^\.//) {
 178                         # dot indicates start of a new row
 179                         push @rows, '<tr>';
 180                         if ($cell =~ s/^>//) {
 181                                 # header cell text follows
 182                                 $cell =~ s/_/ /g;  # underscores may be used instead of whitespace (for qw//ability)
 183                                 $rows[-1] .= '<th>'.($cell || '&nbsp;');
 184                         }
 185                         next;
 186                 }
 187                 elsif ($cell eq '>') {
 188                         # merge this cell to the next column
 189                         $colspan++;
 190                         next;
 191                 }
 192
 193                 $rows[-1] .= $self->cell($cell,
 194                         $colspan > 1 && qq{ colspan="$colspan"},
 195                 );
 196
 197                 $colspan = 1;
 198         }
 199
 200         return sprintf qq{<table class="glyphs%s">\n%s</table>\n},
 201                 @{ $self->{anno} } ? ' dilabel' : '',
 202                 join '', map {"$_\n"} @rows;
 203 }
 204
 205 sub print {
 206         my $self = shift;
 207         while (@_) {
 208                 printf '<div class="section"><h2>%s</h2>'."\n\n", shift;
 209                 while (ref $_[0] and $_ = shift) {
 210                         print $self->table($_);
 211                 }
 212                 print '</div>';
 213         }
 214 }
 215
 216 1;
 217