/[suikacvs]/markup/html/whatpm/Whatpm/HTMLTable.pm
Suika

Contents of /markup/html/whatpm/Whatpm/HTMLTable.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations) (download)
Mon May 5 08:00:25 2008 UTC (16 years, 6 months ago) by wakaba
Branch: MAIN
Changes since 1.8: +70 -49 lines
++ whatpm/Whatpm/ChangeLog	5 May 2008 07:35:54 -0000
	* HTMLTable.pm: How table model errors are detected is
	changed (HTML5 revision 1387).

2008-05-05  Wakaba  <wakaba@suika.fam.cx>

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 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24