unicode: prevent empty row at table header rows
[sheet.git] / 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.03';
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 { digraph => 1, unicode => 0 }, $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, 'di-invalid';
75                 $cell = '';
76         }
77         else {
78                 push @class, 'X';
79
80                 if ($input =~ s/^-//) {
81                         push @class, 'di-rare'; # discouraged
82                 }
83
84                 ($cell, $title, my $class, $mnem) = $self->glyphs_html($input);
85
86                 if ($self->{digraph}) {
87                         if (defined $mnem) {
88                                 push @class, 'di-d'; # digraph
89                                 push @class, 'di-prop' if $class =~ /\bXz\b/; # unofficial
90                         }
91                 }
92                 else {
93                         my $codepoint = ord(substr $input, 0, 1);
94                         if ($codepoint <= 0xFF) {
95                                 push @class, 'di-d';  # latin1
96                         }
97                         elsif ($codepoint <= 0xD7FF) {
98                                 push @class, 'di-prop';  # bmp
99                         }
100                 }
101
102                 if ($input =~ /[ -~]/) {
103                         push @class, 'di-a'; # ascii
104                 }
105                 else {
106                         push @class, 'di-b'; # basic unicode
107                 }
108         }
109
110         return sprintf('<td%s%s%s>%s%s',
111                 defined $title  ? qq{ title="$title"}  : '',
112                 @class ? sprintf(' class="%s"', join ' ', @class) : '',
113                 $html || '',
114                 $cell eq '' ? ('&nbsp;', '') : ($cell,
115                         $self->{digraph} && defined $mnem && length $mnem
116                         ? sprintf(' <small class="digraph">%s</small>', EscapeHTML($mnem))
117                         : $self->{unicode} + $cell =~ /^[^a-zA-Z]$/ > 0
118                                 ? sprintf(' <small class="%s">%04X</small>', 'value', ord $cell)
119                                 : ''
120                 ),
121         );
122 }
123
124 sub table {
125         my ($self, $digraphs) = @_;
126
127         my @rows;
128
129         my @colheads;
130         while ($digraphs->[0] !~ /^\./) {
131                 my $cell = shift @$digraphs or last;
132                 push @colheads, sprintf(
133                         '<%s%s>%s',
134                         $cell =~ s/^-// ? 'td' : 'th',
135                         $cell =~ s/:(.*)// ? qq{ title="$1"} : '',
136                         $cell eq '_' ? '&nbsp;' : $cell
137                 );
138         }
139         push @rows, sprintf '<thead><tr>%s<tbody>', join '', @colheads if @colheads;
140
141         my $colspan = 1;
142         for my $cell (@$digraphs) {
143                 if ($cell =~ s/^\.//) {
144                         # dot indicates start of a new row
145                         push @rows, '<tr>';
146                         if ($cell =~ s/^>//) {
147                                 # header cell text follows
148                                 $cell =~ s/_/ /g;  # underscores may be used instead of whitespace (for qw//ability)
149                                 $rows[-1] .= '<th>'.($cell || '&nbsp;');
150                         }
151                         next;
152                 }
153                 elsif ($cell eq '>') {
154                         # merge this cell to the next column
155                         $colspan++;
156                         next;
157                 }
158
159                 $rows[-1] .= $self->cell($cell,
160                         $colspan > 1 && qq{ colspan="$colspan"},
161                 );
162
163                 $colspan = 1;
164         }
165
166         return sprintf qq{<table class="glyphs%s">\n%s</table>\n},
167                 $self->{digraph} || $self->{unicode} >= 0 ? ' dilabel' : '',
168                 join '', map {"$_\n"} @rows;
169 }
170
171 sub print {
172         my $self = shift;
173         while (@_) {
174                 printf '<div class="section"><h2>%s</h2>'."\n\n", shift;
175                 while (ref $_[0] and $_ = shift) {
176                         print $self->table($_);
177                 }
178                 print '</div>';
179         }
180 }
181
182 1;
183