1 |
wakaba |
1.1 |
package Whatpm::HTMLTable; |
2 |
|
|
use strict; |
3 |
|
|
|
4 |
|
|
## An implementation of "Forming a table" algorithm in HTML5 |
5 |
wakaba |
1.9 |
sub form_table ($$$;$) { |
6 |
|
|
my (undef, $table_el, $onerror, $must_level) = @_; |
7 |
wakaba |
1.2 |
$onerror ||= sub { }; |
8 |
wakaba |
1.9 |
$must_level ||= 'm'; |
9 |
wakaba |
1.1 |
|
10 |
|
|
## Step 1 |
11 |
wakaba |
1.7 |
my $x_width = 0; |
12 |
wakaba |
1.1 |
|
13 |
|
|
## Step 2 |
14 |
wakaba |
1.7 |
my $y_height = 0; |
15 |
wakaba |
1.1 |
my $y_max_node; |
16 |
wakaba |
1.8 |
|
17 |
|
|
## Step 3 |
18 |
|
|
my $pending_tfoot = []; |
19 |
wakaba |
1.1 |
|
20 |
wakaba |
1.8 |
## Step 4 |
21 |
wakaba |
1.1 |
my $table = { |
22 |
|
|
#caption |
23 |
|
|
column => [], |
24 |
|
|
column_group => [], |
25 |
wakaba |
1.9 |
row => [], ## NOTE: HTML5 algorithm doesn't associate rows with <tr>s. |
26 |
wakaba |
1.1 |
row_group => [], |
27 |
|
|
cell => [], |
28 |
|
|
}; |
29 |
|
|
|
30 |
wakaba |
1.9 |
my @column_has_anchored_cell; |
31 |
|
|
my @row_has_anchored_cell; |
32 |
wakaba |
1.1 |
my @column_generated_by; |
33 |
wakaba |
1.9 |
my @row_generated_by; |
34 |
|
|
|
35 |
|
|
## Step 5 |
36 |
|
|
my @table_child = @{$table_el->child_nodes}; |
37 |
|
|
return $table unless @table_child; |
38 |
|
|
|
39 |
|
|
my $process_row_group; |
40 |
|
|
my $end = sub { |
41 |
|
|
## Step 20 (End) |
42 |
|
|
for (@$pending_tfoot) { |
43 |
|
|
$process_row_group->($_); |
44 |
|
|
} |
45 |
|
|
|
46 |
|
|
## Step 21 |
47 |
wakaba |
1.7 |
for (0 .. $x_width - 1) { |
48 |
wakaba |
1.9 |
unless ($column_has_anchored_cell[$_]) { |
49 |
wakaba |
1.1 |
if ($table->{column}->[$_]) { |
50 |
|
|
$onerror->(type => 'column with no anchored cell', |
51 |
wakaba |
1.9 |
node => $table->{column}->[$_]->{element}, |
52 |
|
|
level => $must_level); |
53 |
wakaba |
1.1 |
} else { |
54 |
wakaba |
1.4 |
$onerror->(type => 'colspan creates column with no anchored cell', |
55 |
wakaba |
1.9 |
node => $column_generated_by[$_], |
56 |
|
|
level => $must_level); |
57 |
wakaba |
1.1 |
} |
58 |
wakaba |
1.9 |
last; # only one error. |
59 |
wakaba |
1.1 |
} |
60 |
|
|
} |
61 |
wakaba |
1.9 |
for (0 .. $y_height - 1) { |
62 |
|
|
unless ($row_has_anchored_cell[$_]) { |
63 |
|
|
if ($table->{row}->[$_]) { |
64 |
|
|
$onerror->(type => 'row with no anchored cell', |
65 |
|
|
node => $table->{row}->[$_]->{element}, |
66 |
|
|
level => $must_level); |
67 |
|
|
} else { |
68 |
|
|
$onerror->(type => 'rowspan creates row with no anchored cell', |
69 |
|
|
node => $row_generated_by[$_], |
70 |
|
|
level => $must_level); |
71 |
|
|
} |
72 |
|
|
last; # only one error. |
73 |
|
|
} |
74 |
|
|
} |
75 |
|
|
|
76 |
|
|
## Step 22 |
77 |
|
|
#return $table; |
78 |
|
|
}; # $end |
79 |
wakaba |
1.1 |
|
80 |
wakaba |
1.8 |
## Step 6, 7, 9 |
81 |
wakaba |
1.1 |
my $current_element; |
82 |
|
|
my $current_ln; |
83 |
|
|
NEXT_CHILD: { |
84 |
|
|
$current_element = shift @table_child; |
85 |
|
|
if (defined $current_element) { |
86 |
|
|
redo NEXT_CHILD unless $current_element->node_type == 1; |
87 |
|
|
my $nsuri = $current_element->namespace_uri; |
88 |
|
|
redo NEXT_CHILD unless defined $nsuri and |
89 |
|
|
$nsuri eq q<http://www.w3.org/1999/xhtml>; |
90 |
|
|
$current_ln = $current_element->manakai_local_name; |
91 |
|
|
|
92 |
|
|
if ($current_ln eq 'caption' and not defined $table->{caption}) { |
93 |
wakaba |
1.8 |
## Step 8 |
94 |
wakaba |
1.1 |
$table->{caption} = {element => $current_element}; |
95 |
wakaba |
1.8 |
redo NEXT_CHILD; # Step 9 |
96 |
wakaba |
1.1 |
} |
97 |
|
|
|
98 |
|
|
redo NEXT_CHILD unless { |
99 |
wakaba |
1.8 |
#caption => 1, ## Step 7 |
100 |
wakaba |
1.1 |
colgroup => 1, |
101 |
|
|
thead => 1, |
102 |
|
|
tbody => 1, |
103 |
|
|
tfoot => 1, |
104 |
|
|
tr => 1, |
105 |
|
|
}->{$current_ln}; |
106 |
|
|
} else { |
107 |
|
|
## End of subsection |
108 |
wakaba |
1.9 |
|
109 |
wakaba |
1.8 |
## Step 6 2nd paragraph |
110 |
wakaba |
1.9 |
$end->(); |
111 |
|
|
return $table; |
112 |
wakaba |
1.1 |
} |
113 |
|
|
} # NEXT_CHILD |
114 |
|
|
|
115 |
wakaba |
1.8 |
## Step 10 |
116 |
|
|
while ($current_ln eq 'colgroup') { # Step 10, Step 10.4 |
117 |
|
|
## Step 10.1: column groups |
118 |
wakaba |
1.1 |
my @col = grep { |
119 |
|
|
$_->node_type == 1 and |
120 |
|
|
defined $_->namespace_uri and |
121 |
|
|
$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and |
122 |
|
|
$_->manakai_local_name eq 'col' |
123 |
|
|
} @{$current_element->child_nodes}; |
124 |
|
|
if (@col) { |
125 |
|
|
## Step 1 |
126 |
wakaba |
1.7 |
my $x_start = $x_width; |
127 |
wakaba |
1.1 |
|
128 |
|
|
## Step 2, 6 |
129 |
|
|
while (@col) { |
130 |
|
|
my $current_column = shift @col; |
131 |
|
|
|
132 |
|
|
## Step 3: columns |
133 |
|
|
my $span = 1; |
134 |
|
|
my $col_span = $current_column->get_attribute_ns (undef, 'span'); |
135 |
|
|
## Parse non-negative integer |
136 |
|
|
if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) { |
137 |
|
|
$span = $1 || 1; |
138 |
|
|
} |
139 |
|
|
## ISSUE: If span=0, what is /span/ value? |
140 |
|
|
|
141 |
|
|
## Step 4, 5 |
142 |
wakaba |
1.7 |
$table->{column}->[++$x_width] = {element => $current_column} |
143 |
|
|
for 1..$span; |
144 |
wakaba |
1.1 |
} |
145 |
|
|
|
146 |
|
|
## Step 7 |
147 |
|
|
my $cg = {element => $current_element, |
148 |
wakaba |
1.7 |
x => $x_start, y => 0, |
149 |
|
|
width => $x_width - $x_start}; |
150 |
|
|
$table->{column_group}->[$_] = $cg for $x_start .. $x_width - 1; |
151 |
wakaba |
1.1 |
} else { # no <col> children |
152 |
|
|
## Step 1 |
153 |
|
|
my $span = 1; |
154 |
|
|
my $col_span = $current_element->get_attribute_ns (undef, 'span'); |
155 |
|
|
## Parse non-negative integer |
156 |
|
|
if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) { |
157 |
|
|
$span = $1 || 1; |
158 |
|
|
} |
159 |
|
|
## ISSUE: If span=0, what is /span/ value? |
160 |
|
|
|
161 |
|
|
## Step 2 |
162 |
wakaba |
1.7 |
$x_width += $span; |
163 |
wakaba |
1.1 |
|
164 |
|
|
## Step 3 |
165 |
|
|
my $cg = {element => $current_element, |
166 |
wakaba |
1.7 |
x => $x_width - $span, y => 0, |
167 |
wakaba |
1.1 |
width => $span}; |
168 |
wakaba |
1.7 |
$table->{column_group}->[$_] = $cg for $cg->{x} .. $x_width - 1; |
169 |
wakaba |
1.1 |
} |
170 |
|
|
|
171 |
wakaba |
1.8 |
## Step 10.2, 10.3 |
172 |
wakaba |
1.1 |
NEXT_CHILD: { |
173 |
|
|
$current_element = shift @table_child; |
174 |
|
|
if (defined $current_element) { |
175 |
|
|
redo NEXT_CHILD unless $current_element->node_type == 1; |
176 |
|
|
my $nsuri = $current_element->namespace_uri; |
177 |
|
|
redo NEXT_CHILD unless defined $nsuri and |
178 |
|
|
$nsuri eq q<http://www.w3.org/1999/xhtml>; |
179 |
|
|
$current_ln = $current_element->manakai_local_name; |
180 |
|
|
|
181 |
|
|
redo NEXT_CHILD unless { |
182 |
|
|
colgroup => 1, |
183 |
|
|
thead => 1, |
184 |
|
|
tbody => 1, |
185 |
|
|
tfoot => 1, |
186 |
|
|
tr => 1, |
187 |
|
|
}->{$current_ln}; |
188 |
|
|
} else { |
189 |
|
|
## End of subsection |
190 |
wakaba |
1.9 |
|
191 |
wakaba |
1.1 |
## Step 5 of overall steps 2nd paragraph |
192 |
wakaba |
1.9 |
$end->(); |
193 |
|
|
return $table; |
194 |
wakaba |
1.1 |
} |
195 |
|
|
} # NEXT_CHILD |
196 |
|
|
} |
197 |
|
|
|
198 |
wakaba |
1.8 |
## Step 11 |
199 |
wakaba |
1.1 |
my $y_current = 0; |
200 |
|
|
|
201 |
wakaba |
1.8 |
## Step 12 |
202 |
wakaba |
1.1 |
my @downward_growing_cells; |
203 |
|
|
|
204 |
|
|
my $growing_downward_growing_cells = sub { |
205 |
|
|
for (@downward_growing_cells) { |
206 |
|
|
for my $x ($_->[1] .. ($_->[1] + $_->[2] - 1)) { |
207 |
|
|
$table->{cell}->[$x]->[$y_current] = [$_->[0]]; |
208 |
|
|
$_->[0]->{height}++; |
209 |
|
|
} |
210 |
|
|
} |
211 |
|
|
}; # $growing_downward_growing_cells |
212 |
|
|
|
213 |
|
|
my $process_row = sub { |
214 |
|
|
## Step 1 |
215 |
wakaba |
1.7 |
$y_height++ if $y_height == $y_current; |
216 |
wakaba |
1.1 |
|
217 |
|
|
## Step 2 |
218 |
wakaba |
1.7 |
my $x_current = 0; |
219 |
|
|
|
220 |
wakaba |
1.1 |
## Step 3 |
221 |
|
|
my $tr = shift; |
222 |
wakaba |
1.9 |
$table->{row}->[$y_current] = {element => $tr}; |
223 |
wakaba |
1.1 |
my @tdth = grep { |
224 |
|
|
$_->node_type == 1 and |
225 |
|
|
defined $_->namespace_uri and |
226 |
|
|
$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and |
227 |
|
|
{td => 1, th => 1}->{$_->manakai_local_name} |
228 |
|
|
} @{$tr->child_nodes}; |
229 |
wakaba |
1.7 |
my $current_cell = shift @tdth; |
230 |
|
|
|
231 |
|
|
## Step 4 |
232 |
|
|
$growing_downward_growing_cells->(); |
233 |
wakaba |
1.1 |
|
234 |
wakaba |
1.9 |
return unless $current_cell; |
235 |
|
|
## ISSUE: Support for empty <tr></tr> (removed at revision 1376). |
236 |
|
|
|
237 |
wakaba |
1.7 |
CELL: while (1) { |
238 |
|
|
## Step 5: cells |
239 |
wakaba |
1.1 |
$x_current++ |
240 |
wakaba |
1.7 |
while ($x_current < $x_width and |
241 |
wakaba |
1.1 |
$table->{cell}->[$x_current]->[$y_current]); |
242 |
|
|
|
243 |
wakaba |
1.7 |
## Step 6 |
244 |
|
|
$x_width++ if $x_current == $x_width; |
245 |
|
|
|
246 |
wakaba |
1.1 |
## Step 7 |
247 |
|
|
my $colspan = 1; |
248 |
|
|
my $attr_value = $current_cell->get_attribute_ns (undef, 'colspan'); |
249 |
|
|
if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) { |
250 |
|
|
$colspan = $1 || 1; |
251 |
|
|
} |
252 |
|
|
|
253 |
wakaba |
1.7 |
## Step 8 |
254 |
wakaba |
1.1 |
my $rowspan = 1; |
255 |
|
|
my $attr_value = $current_cell->get_attribute_ns (undef, 'rowspan'); |
256 |
|
|
if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) { |
257 |
|
|
$rowspan = $1; |
258 |
|
|
} |
259 |
|
|
|
260 |
wakaba |
1.7 |
## Step 9 |
261 |
wakaba |
1.1 |
my $cell_grows_downward; |
262 |
|
|
if ($rowspan == 0) { |
263 |
|
|
$cell_grows_downward = 1; |
264 |
|
|
$rowspan = 1; |
265 |
|
|
} |
266 |
|
|
|
267 |
wakaba |
1.7 |
## Step 10 |
268 |
|
|
if ($x_width < $x_current + $colspan) { |
269 |
wakaba |
1.1 |
@column_generated_by[$_] = $current_cell |
270 |
wakaba |
1.7 |
for $x_width .. $x_current + $colspan - 1; |
271 |
|
|
$x_width = $x_current + $colspan; |
272 |
wakaba |
1.1 |
} |
273 |
|
|
|
274 |
wakaba |
1.7 |
## Step 11 |
275 |
|
|
if ($y_height < $y_current + $rowspan) { |
276 |
wakaba |
1.9 |
@row_generated_by[$_] = $current_cell |
277 |
|
|
for $y_height .. $y_current + $rowspan - 1; |
278 |
wakaba |
1.7 |
$y_height = $y_current + $rowspan; |
279 |
wakaba |
1.1 |
$y_max_node = $current_cell; |
280 |
|
|
} |
281 |
|
|
|
282 |
wakaba |
1.7 |
## Step 12 |
283 |
wakaba |
1.1 |
my $cell = { |
284 |
wakaba |
1.2 |
is_header => ($current_cell->manakai_local_name eq 'th'), |
285 |
wakaba |
1.1 |
element => $current_cell, |
286 |
|
|
x => $x_current, y => $y_current, |
287 |
|
|
width => $colspan, height => $rowspan, |
288 |
|
|
}; |
289 |
wakaba |
1.9 |
$column_has_anchored_cell[$x_current] = 1; |
290 |
|
|
$row_has_anchored_cell[$y_current] = 1; |
291 |
wakaba |
1.1 |
for my $x ($x_current .. ($x_current + $colspan - 1)) { |
292 |
|
|
for my $y ($y_current .. ($y_current + $rowspan - 1)) { |
293 |
|
|
unless ($table->{cell}->[$x]->[$y]) { |
294 |
|
|
$table->{cell}->[$x]->[$y] = [$cell]; |
295 |
|
|
} else { |
296 |
wakaba |
1.9 |
$onerror->(type => "cell overlapping:$x:$y", node => $current_cell, |
297 |
|
|
level => $must_level); |
298 |
wakaba |
1.1 |
push @{$table->{cell}->[$x]->[$y]}, $cell; |
299 |
|
|
} |
300 |
|
|
} |
301 |
|
|
} |
302 |
|
|
|
303 |
wakaba |
1.7 |
## Step 13 |
304 |
wakaba |
1.1 |
if ($cell_grows_downward) { |
305 |
|
|
push @downward_growing_cells, [$cell, $x_current, $colspan]; |
306 |
|
|
} |
307 |
|
|
|
308 |
wakaba |
1.7 |
## Step 14 |
309 |
wakaba |
1.1 |
$x_current += $colspan; |
310 |
wakaba |
1.7 |
|
311 |
|
|
## Step 15-17 |
312 |
|
|
$current_cell = shift @tdth; |
313 |
|
|
if (defined $current_cell) { |
314 |
|
|
## Step 16-17 |
315 |
|
|
# |
316 |
|
|
} else { |
317 |
|
|
## Step 15 |
318 |
|
|
$y_current++; |
319 |
|
|
last CELL; |
320 |
|
|
} |
321 |
|
|
} # CELL |
322 |
wakaba |
1.1 |
}; # $process_row |
323 |
|
|
|
324 |
wakaba |
1.9 |
$process_row_group = sub ($) { |
325 |
wakaba |
1.8 |
## Step 1 |
326 |
|
|
my $y_start = $y_height; |
327 |
|
|
|
328 |
|
|
## Step 2 |
329 |
|
|
for (grep { |
330 |
|
|
$_->node_type == 1 and |
331 |
|
|
defined $_->namespace_uri and |
332 |
|
|
$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and |
333 |
|
|
$_->manakai_local_name eq 'tr' |
334 |
|
|
} @{$_[0]->child_nodes}) { |
335 |
|
|
$process_row->($_); |
336 |
|
|
} |
337 |
|
|
|
338 |
|
|
## Step 3 |
339 |
|
|
if ($y_height > $y_start) { |
340 |
|
|
my $rg = {element => $current_element, ## ISSUE: "element being processed"? |
341 |
|
|
x => 0, y => $y_start, |
342 |
|
|
height => $y_height - $y_start}; |
343 |
|
|
$table->{row_group}->[$_] = $rg for $y_start .. $y_height - 1; |
344 |
|
|
} |
345 |
|
|
|
346 |
|
|
## Step 4 |
347 |
|
|
## Ending a row group |
348 |
|
|
## Step 1 |
349 |
|
|
while ($y_current < $y_height) { |
350 |
|
|
## Step 1 |
351 |
|
|
$growing_downward_growing_cells->(); |
352 |
|
|
|
353 |
|
|
## Step 2 |
354 |
|
|
$y_current++; |
355 |
|
|
} |
356 |
wakaba |
1.9 |
## Step 2 |
357 |
wakaba |
1.8 |
@downward_growing_cells = (); |
358 |
|
|
}; # $process_row_group |
359 |
|
|
|
360 |
|
|
## Step 13: rows |
361 |
wakaba |
1.1 |
unshift @table_child, $current_element; |
362 |
|
|
ROWS: { |
363 |
|
|
NEXT_CHILD: { |
364 |
|
|
$current_element = shift @table_child; |
365 |
|
|
if (defined $current_element) { |
366 |
|
|
redo NEXT_CHILD unless $current_element->node_type == 1; |
367 |
|
|
my $nsuri = $current_element->namespace_uri; |
368 |
|
|
redo NEXT_CHILD unless defined $nsuri and |
369 |
|
|
$nsuri eq q<http://www.w3.org/1999/xhtml>; |
370 |
|
|
$current_ln = $current_element->manakai_local_name; |
371 |
|
|
|
372 |
|
|
redo NEXT_CHILD unless { |
373 |
|
|
thead => 1, |
374 |
|
|
tbody => 1, |
375 |
|
|
tfoot => 1, |
376 |
|
|
tr => 1, |
377 |
|
|
}->{$current_ln}; |
378 |
|
|
} else { |
379 |
wakaba |
1.8 |
## Step 6 2nd paragraph |
380 |
wakaba |
1.9 |
$end->(); |
381 |
|
|
return $table; |
382 |
wakaba |
1.1 |
} |
383 |
|
|
} # NEXT_CHILD |
384 |
|
|
|
385 |
wakaba |
1.8 |
## Step 14 |
386 |
wakaba |
1.1 |
if ($current_ln eq 'tr') { |
387 |
|
|
$process_row->($current_element); |
388 |
wakaba |
1.8 |
# advance (done at the first of ROWS) |
389 |
wakaba |
1.1 |
redo ROWS; |
390 |
|
|
} |
391 |
|
|
|
392 |
wakaba |
1.8 |
## Step 15 |
393 |
wakaba |
1.1 |
## Ending a row group |
394 |
|
|
## Step 1 |
395 |
wakaba |
1.7 |
while ($y_current < $y_height) { |
396 |
wakaba |
1.1 |
## Step 1 |
397 |
wakaba |
1.9 |
$growing_downward_growing_cells->(); |
398 |
|
|
|
399 |
|
|
## Step 2 |
400 |
wakaba |
1.1 |
$y_current++; |
401 |
|
|
} |
402 |
wakaba |
1.9 |
## Step 2 |
403 |
wakaba |
1.1 |
@downward_growing_cells = (); |
404 |
|
|
|
405 |
|
|
## Step 16 |
406 |
wakaba |
1.8 |
if ($current_ln eq 'tfoot') { |
407 |
|
|
push @$pending_tfoot, $current_element; |
408 |
|
|
# advance (done at the top of ROWS) |
409 |
|
|
redo ROWS; |
410 |
wakaba |
1.1 |
} |
411 |
|
|
|
412 |
|
|
## Step 17 |
413 |
wakaba |
1.8 |
# thead or tbody |
414 |
|
|
$process_row_group->($current_element); |
415 |
wakaba |
1.1 |
|
416 |
|
|
## Step 18 |
417 |
wakaba |
1.8 |
# Advance (done at the top of ROWS). |
418 |
wakaba |
1.1 |
|
419 |
|
|
## Step 19 |
420 |
wakaba |
1.8 |
redo ROWS; |
421 |
wakaba |
1.1 |
} # ROWS |
422 |
wakaba |
1.8 |
|
423 |
wakaba |
1.9 |
$end->(); |
424 |
wakaba |
1.8 |
return $table; |
425 |
wakaba |
1.1 |
} # form_table |
426 |
|
|
|
427 |
|
|
## TODO: Implement scope="" algorithm |
428 |
|
|
|
429 |
|
|
1; |
430 |
wakaba |
1.9 |
## $Date: 2008/05/05 06:57:07 $ |