Shiar_Sheet/FormatChar.pm

   1 package Shiar_Sheet::FormatChar;
   2
   3 use 5.010;
   4 use strict;
   5 use warnings;
   6 use utf8;
   7
   8 use Data::Dump 'pp';
   9 use PLP::Functions 'EscapeHTML';
  10
  11 our $VERSION = '1.08';
  12
  13 our $uc = do 'data/unicode-char.inc.pl';
  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         return $uc->{chr $codepoint} || eval {
  23                 require Unicode::UCD;
  24                 if (my $fullinfo = Unicode::UCD::charinfo($codepoint)) {
  25                         return [@$fullinfo{qw/category name - string/}];
  26                 }
  27         } || [];
  28 }
  29
  30 sub glyph_html {
  31         my ($self, $char) = @_;
  32         my $codepoint = ord $char;
  33         my $info = $self->glyph_info($codepoint);
  34         my ($class, $name, $mnem, $entity, $string) = @$info;
  35
  36         my $cell = EscapeHTML($string || $char);
  37         my $title = sprintf 'U+%04X%s', $codepoint, !!$name && " ($name)";
  38
  39         $cell = "<span>$cell</span>" if $class and $class =~ /\bZs\b/;
  40         $cell = '&nbsp;' if $cell eq '';
  41
  42         return ($cell, EscapeHTML($title), !!$class && "X $class", $mnem, $entity);
  43 }
  44
  45 sub glyphs_html {
  46         my $self = shift;
  47
  48         return $self->glyph_html(@_) if length $_[0] <= 1;
  49
  50         my @chars = map { [ $self->glyph_html($_) ] } split //, $_[0];
  51         return (
  52                 EscapeHTML($_[0]), # cell
  53                 join(' | ', map { $_->[1] } @chars), # title
  54                 $chars[0][2], # class
  55                 join(' ',  map { $_->[3] // '…' } @chars), # digraph
  56         );
  57 }
  58
  59 sub glyph_cell {
  60         my ($self, $char) = @_;
  61         return sprintf('<td class="%3$s" title="%2$s">%s', $self->glyph_html($char));
  62 }
  63
  64 sub cell {
  65         my ($self, $input, $html) = @_;
  66         my (@class, $title, $cell, $mnem, $entity);
  67
  68         if ($input eq '-') {
  69                 $cell = '';
  70         }
  71         elsif ($input eq '=') {
  72                 push @class, 'u-invalid';
  73                 $cell = '';
  74         }
  75         else {{
  76                 push @class, 'X';
  77
  78                 if ($input =~ s/^-//) {
  79                         push @class, 'ex'; # discouraged
  80                 }
  81
  82                 $input =~ s/^\\//;  # escaped char
  83                 ($cell, $title, my $class, $mnem, $entity) = $self->glyphs_html($input);
  84                 my $codepoint = ord $input;
  85
  86                 if ($self->{style} eq 'univer') {
  87                         if ($input =~ /\p{age=unassigned}/) {
  88                                 # check include for assignments after unicode 6.0 (perl v5.14)
  89                                 state $agemap = do 'data/unicode-age.inc.pl';
  90                                 my $version = $agemap->{$codepoint};
  91                                 push @class, $version ? 'l2' : 'l1';
  92                         }
  93                         elsif ($input =~ /^\p{in=1.1}*$/) {
  94                                 push @class, 'l5';  # first release 1993
  95                         }
  96                         elsif ($input =~ /^\p{in=3.0}*$/) {
  97                                 push @class, 'l4';  # 20th century
  98                         }
  99                         elsif ($input =~ /^\p{in=4.1}*$/) {
 100                                 push @class, 'l4';  # over 10 years ago
 101                         }
 102                         elsif ($input =~ /^\p{in=6.0}*$/) {
 103                                 push @class, 'l3';  # before 2012
 104                         }
 105                         else {
 106                                 push @class, 'l2';  # more recent
 107                         }
 108                         next;
 109                 }
 110
 111                 if ($self->{style} eq 'di') {
 112                         if ($mnem and $mnem =~ /…/) {
 113                                 # incomplete representation, usually partial
 114                         }
 115                         elsif ($class =~ /\bu-di\b/) {
 116                                 push @class, ('l4', 'u-di'); # standard digraph
 117                         }
 118                         elsif ($class =~ /\bu-prop\b/) {
 119                                 push @class, ('l3', 'u-prop'); # unofficial
 120                         }
 121                 }
 122                 elsif ($self->{style} eq 'html') {
 123                         if (defined $entity) {
 124                                 push @class, ($codepoint <= 0xFF ? 'l4' : 'l3', 'u-html');
 125                         }
 126                 }
 127                 else {
 128                         if ($codepoint <= 0xFF) {
 129                                 push @class, 'l4', 'u-lat1';  # latin1
 130                         }
 131                         elsif ($codepoint <= 0xD7FF) {
 132                                 push @class, 'l3', 'u-bmp';  # bmp
 133                         }
 134                 }
 135
 136                 if ($input =~ /[ -~]/) {
 137                         push @class, 'l5', 'u-ascii'; # ascii
 138                 }
 139                 elsif ($input =~ /^\p{in=6.0}+$/ and $input !~ /\p{Co}/) {
 140                         push @class, 'l2'; # in unicode 6.0
 141                 }
 142                 else {
 143                         push @class, 'l1'; # any unicode
 144                 }
 145         }}
 146
 147         my $anno = '';
 148         if ($cell ne '') {
 149                 for (@{ $self->{anno} }) {
 150                         if (/html$/) {
 151                                 if (defined $entity) {
 152                                         $entity = "&$entity;" if /^&/;
 153                                         $anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($entity));
 154                                         last;
 155                                 }
 156                         }
 157                         elsif ($_ eq 'xml') {
 158                                 $anno = sprintf(' <small class="digraph">%s</small>',
 159                                         sprintf '#%d', ord($cell)
 160                                 );
 161                                 last;
 162                         }
 163                         elsif ($_ eq '&xml') {
 164                                 $anno = sprintf(' <small class="digraph">%s</small>',
 165                                         sprintf '&amp;#%d;', ord($cell)
 166                                 );
 167                                 last;
 168                         }
 169                         elsif ($_ eq 'di') {
 170                                 if (defined $mnem and length $mnem) {
 171                                         $anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($mnem));
 172                                         last;
 173                                 }
 174                         }
 175                         else {
 176                                 if ($_ eq 'hex' or $input =~ /^[^a-zA-Z]$/) {
 177                                         $anno = sprintf(' <small class="%s">%04X</small>', 'value', ord $input);
 178                                         last;
 179                                 }
 180                         }
 181                 }
 182         }
 183
 184         return sprintf('<%s>%s%s',
 185                 join(' ', 'td',
 186                         defined $title ? qq{title="$title"}  : (),
 187                         @class ? sprintf('class="%s"', join ' ', @class) : (),
 188                         $html || (),
 189                 ),
 190                 $cell eq '' ? '&nbsp;' : $cell,
 191                 $anno,
 192         );
 193 }
 194
 195 sub row {
 196         my ($self, $cells) = @_;
 197         my @html;
 198
 199         my $colspan = 1;
 200         for my $cell (@{$cells}) {
 201                 if ($cell =~ s/^\.//) {
 202                         # dot indicates start of a new row
 203                         push @html, '<tr>';
 204                         if ($cell =~ s/^>//) {
 205                                 # header cell text follows
 206                                 $cell =~ s/_/ /g;  # underscores may be used instead of whitespace (for qw//ability)
 207                                 my $class = $cell =~ s/^-// && ' class="ex"';
 208                                 $html[-1] .= "<th$class>".($cell || '&nbsp;');
 209                         }
 210                         next;
 211                 }
 212                 elsif ($cell eq '>') {
 213                         # merge this cell to the next column
 214                         $colspan++;
 215                         next;
 216                 }
 217                 elsif ($cell eq '>-') {
 218                         $html[-1] .= '<th>';
 219                         next;
 220                 }
 221                 elsif ($cell =~ m/^</) {
 222                         $html[-1] .= '<td>'.$cell;
 223                         next;
 224                 }
 225
 226                 $html[-1] .= $self->cell($cell,
 227                         $colspan > 1 && qq{colspan="$colspan"},
 228                 );
 229
 230                 $colspan = 1;
 231         }
 232
 233         return @html;
 234 }
 235
 236 sub tabletag {
 237         my ($self) = @_;
 238         my $class = 'glyphs';
 239         $class .= ' dilabel' if @{ $self->{anno} };
 240         return sprintf '<table class="%s">', $class;
 241 }
 242
 243 sub table {
 244         my ($self, $digraphs) = @_;
 245
 246         my @rows;
 247
 248         my @colheads;
 249         while ($digraphs->[0] !~ /^\./) {
 250                 my $cell = shift @$digraphs or last;
 251                 if ($cell eq '>') {
 252                         push @colheads, '<tr>';
 253                         next;
 254                 }
 255                 push @colheads, join('',
 256                         '<',
 257                         $cell =~ s/^-// ? 'td' : 'th',
 258                         $cell =~ s/:(.*)// && qq{ title="$1"},
 259                         $cell =~ s/^(>+)// && ' colspan='.(length($1) + 1),
 260                         '>',
 261                         $cell eq '_' ? '&nbsp;' : $cell
 262                 );
 263         }
 264         push @rows, sprintf '<thead><tr>%s<tbody>', join '', @colheads if @colheads;
 265         push @rows, $self->row($digraphs);
 266
 267         return join '', map {"$_\n"} $self->tabletag, @rows, '</table>';
 268 }
 269
 270 sub print {
 271         my $self = shift;
 272         while (@_) {
 273                 print '<div class="section">';
 274                 printf '<h2>%s</h2>', shift unless ref $_[0];
 275                 print "\n\n";
 276                 while (ref $_[0] and $_ = shift) {
 277                         print $self->table($_);
 278                 }
 279                 print "\n</div>";
 280         }
 281 }
 282
 283 sub legend {
 284         my $self = shift;
 285         my @classes = $self->{style} eq 'univer' ? (
 286                 [l5 => 'unicode 1.1'],
 287                 [l4 => '20th century'],
 288                 [l3 => 'in 6.0 (2010)'],
 289                 [l2 => 'recent assignments'],
 290                 [l1 => 'proposed'],
 291                 [ex => 'irregular'],
 292         ) : (
 293                 [l5 => 'ascii'],
 294                 [l4 => $self->{style} eq 'di' ? 'digraph' : 'latin1'],
 295                 [l3 => $self->{style} eq 'di' ? 'proposed' : 'HTML4'],
 296                 [l2 => 'unicode ≤6.0'],
 297                 [l1 => 'other unicode'],
 298                 [ex => 'discouraged'],
 299         );
 300
 301         return (
 302                 '<div class="legend"><table class="glyphs"><tr>',
 303                 (map { sprintf '<td class="X %s">%s', @{$_} } @classes),
 304                 '</table></div>',
 305         );
 306 }
 307
 308 1;
 309