whatpm/Whatpm/HTMLTable.pm

package Whatpm::HTMLTable;
use strict;

## r1376

## An implementation of "Forming a table" algorithm in HTML5
sub form_table ($$$) {
  my (undef, $table_el, $onerror) = @_;
  $onerror ||= sub { };
  
  ## Step 1
  my $x_width = 0;

  ## Step 2
  my $y_height = 0;
  my $y_max_node;
  
  ## Step 3
  my $table = {
    #caption
    column => [],
    column_group => [],
    # no |row| since HTML5 algorithm doesn't associate rows with <tr>s
    row_group => [],
    cell => [],
  };
  
  my @has_anchored_cell;
  my @column_generated_by;
  my $check_empty_column = sub {
    for (0 .. $x_width - 1) {
      unless ($has_anchored_cell[$_]) {
        if ($table->{column}->[$_]) {
          $onerror->(type => 'column with no anchored cell',
                     node => $table->{column}->[$_]->{element});
        } else {
          $onerror->(type => 'colspan creates column with no anchored cell',
                     node => $column_generated_by[$_]);
        }
      }
    }
  }; # $check_empty_column
  
  ## Step 4
  my @table_child = @{$table_el->child_nodes};
  return unless @table_child; # don't call $check_empty_column

  ## Step 5, 6, 8
  my $current_element;
  my $current_ln;
  NEXT_CHILD: {
    $current_element = shift @table_child;
    if (defined $current_element) {
      redo NEXT_CHILD unless $current_element->node_type == 1;
      my $nsuri = $current_element->namespace_uri;
      redo NEXT_CHILD unless defined $nsuri and
        $nsuri eq q<http://www.w3.org/1999/xhtml>;
      $current_ln = $current_element->manakai_local_name;

      if ($current_ln eq 'caption' and not defined $table->{caption}) {
        ## Step 7
        $table->{caption} = {element => $current_element};
        redo NEXT_CHILD; # Step 8
      }

      redo NEXT_CHILD unless {
        #caption => 1, ## Step 6
        colgroup => 1,
        thead => 1,
        tbody => 1,
        tfoot => 1,
        tr => 1,
      }->{$current_ln};
    } else {
      ## End of subsection
      $check_empty_column->();
      ## Step 5 2nd paragraph
      return $table;
    }
  } # NEXT_CHILD

  ## Step 9
  while ($current_ln eq 'colgroup') { # Step 9, Step 9.4
    ## Step 9.1: column groups
    my @col = grep {
      $_->node_type == 1 and
      defined $_->namespace_uri and
      $_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
      $_->manakai_local_name eq 'col'
    } @{$current_element->child_nodes};
    if (@col) {
      ## Step 1
      my $x_start = $x_width;
      
      ## Step 2, 6
      while (@col) {
        my $current_column = shift @col;
        
        ## Step 3: columns
        my $span = 1;
        my $col_span = $current_column->get_attribute_ns (undef, 'span');
        ## Parse non-negative integer
        if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
          $span = $1 || 1;
        }
        ## ISSUE: If span=0, what is /span/ value?
        
        ## Step 4, 5
        $table->{column}->[++$x_width] = {element => $current_column}
            for 1..$span;
      }
      
      ## Step 7
      my $cg = {element => $current_element,
                x => $x_start, y => 0,
                width => $x_width - $x_start};
      $table->{column_group}->[$_] = $cg for $x_start .. $x_width - 1;
    } else { # no <col> children
      ## Step 1
      my $span = 1;
      my $col_span = $current_element->get_attribute_ns (undef, 'span');
      ## Parse non-negative integer
      if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
        $span = $1 || 1;
      }
      ## ISSUE: If span=0, what is /span/ value?
      
      ## Step 2
      $x_width += $span;
      
      ## Step 3
      my $cg = {element => $current_element,
                x => $x_width - $span, y => 0,
                width => $span};
      $table->{column_group}->[$_] = $cg for $cg->{x} .. $x_width - 1;
    }
    
    ## Step 9.2, 9.3
    NEXT_CHILD: {
      $current_element = shift @table_child;
      if (defined $current_element) {
        redo NEXT_CHILD unless $current_element->node_type == 1;
        my $nsuri = $current_element->namespace_uri;
        redo NEXT_CHILD unless defined $nsuri and
          $nsuri eq q<http://www.w3.org/1999/xhtml>;
        $current_ln = $current_element->manakai_local_name;
        
        redo NEXT_CHILD unless {
          colgroup => 1,
          thead => 1,
          tbody => 1,
          tfoot => 1,
          tr => 1,
        }->{$current_ln};
      } else {
        ## End of subsection
        $check_empty_column->();
        ## Step 5 of overall steps 2nd paragraph
        return $table;
      }
    } # NEXT_CHILD
  }

  ## Step 10
  my $y_current = 0;

  ## Step 11
  my @downward_growing_cells;

  my $growing_downward_growing_cells = sub {
    for (@downward_growing_cells) {
      for my $x ($_->[1] .. ($_->[1] + $_->[2] - 1)) {
        $table->{cell}->[$x]->[$y_current] = [$_->[0]];
        $_->[0]->{height}++;
      }
    }
  }; # $growing_downward_growing_cells

  my $process_row = sub {
    ## Step 1
    $y_height++ if $y_height == $y_current;
    
    ## Step 2
    my $x_current = 0;

    ## Step 3
    my $tr = shift;
    my @tdth = grep {
      $_->node_type == 1 and
      defined $_->namespace_uri and
      $_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
      {td => 1, th => 1}->{$_->manakai_local_name}
    } @{$tr->child_nodes};
    my $current_cell = shift @tdth;

## ISSUE: Support for empty <tr></tr> (removed at revision 1376).

    ## Step 4
    $growing_downward_growing_cells->();

    CELL: while (1) {
      ## Step 5: cells
      $x_current++
        while ($x_current < $x_width and
               $table->{cell}->[$x_current]->[$y_current]);

      ## Step 6
      $x_width++ if $x_current == $x_width;

      ## Step 7
      my $colspan = 1;
      my $attr_value = $current_cell->get_attribute_ns (undef, 'colspan');
      if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
        $colspan = $1 || 1;
      }
      
      ## Step 8
      my $rowspan = 1;
      my $attr_value = $current_cell->get_attribute_ns (undef, 'rowspan');
      if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
        $rowspan = $1;
      }
      
      ## Step 9
      my $cell_grows_downward;
      if ($rowspan == 0) {
        $cell_grows_downward = 1;
        $rowspan = 1;
      }
      
      ## Step 10
      if ($x_width < $x_current + $colspan) { 
        @column_generated_by[$_] = $current_cell
          for $x_width .. $x_current + $colspan - 1;
        $x_width = $x_current + $colspan;
      }
      
      ## Step 11
      if ($y_height < $y_current + $rowspan) {
        $y_height = $y_current + $rowspan;
        $y_max_node = $current_cell;
      }
      
      ## Step 12
      my $cell = {
                  is_header => ($current_cell->manakai_local_name eq 'th'),
                  element => $current_cell,
                  x => $x_current, y => $y_current,
                  width => $colspan, height => $rowspan,
                 };
      $has_anchored_cell[$x_current] = 1;
      for my $x ($x_current .. ($x_current + $colspan - 1)) {
        for my $y ($y_current .. ($y_current + $rowspan - 1)) {
          unless ($table->{cell}->[$x]->[$y]) {
            $table->{cell}->[$x]->[$y] = [$cell];
          } else {
            $onerror->(type => "cell overlapping:$x:$y", node => $current_cell);
            push @{$table->{cell}->[$x]->[$y]}, $cell;
          }
        }
      }
      
      ## Step 13
      if ($cell_grows_downward) {
        push @downward_growing_cells, [$cell, $x_current, $colspan];
      }
      
      ## Step 14
      $x_current += $colspan;

      ## Step 15-17
      $current_cell = shift @tdth;
      if (defined $current_cell) {
        ## Step 16-17
        #
      } else {
        ## Step 15
        $y_current++;
        last CELL;
      }
    } # CELL
  }; # $process_row

  ## Step 12: rows
  unshift @table_child, $current_element;
  ROWS: {
    NEXT_CHILD: {
      $current_element = shift @table_child;
      if (defined $current_element) {
        redo NEXT_CHILD unless $current_element->node_type == 1;
        my $nsuri = $current_element->namespace_uri;
        redo NEXT_CHILD unless defined $nsuri and
          $nsuri eq q<http://www.w3.org/1999/xhtml>;
        $current_ln = $current_element->manakai_local_name;
      
        redo NEXT_CHILD unless {
          thead => 1,
          tbody => 1,
          tfoot => 1,
          tr => 1,
        }->{$current_ln};
      } else {
        ## Step 10 2nd sentense
        if ($y_current != $y_height) {
          $onerror->(type => 'no cell in last row', node => $table_el);
        }
        ## End of subsection
        $check_empty_column->();
        ## Step 5 2nd paragraph
        return $table;
      }
    } # NEXT_CHILD

    ## Step 13
    if ($current_ln eq 'tr') {
      $process_row->($current_element);
      redo ROWS;
    }

    ## Step 14
    ## Ending a row group
      ## Step 1
      if ($y_current < $y_height) {
        $onerror->(type => 'rowspan expands table', node => $y_max_node);
      }
      ## Step 2
      while ($y_current < $y_height) {
        ## Step 1
        $y_current++;
        $growing_downward_growing_cells->();
      }
      ## Step 3
      @downward_growing_cells = ();
      
    ## Step 15
    my $y_start = $y_height;

    ## Step 16
    for (grep {
      $_->node_type == 1 and
      defined $_->namespace_uri and
      $_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
      $_->manakai_local_name eq 'tr'
    } @{$current_element->child_nodes}) {
      $process_row->($_);
    }

    ## Step 17
    if ($y_height > $y_start) {
      my $rg = {element => $current_element,
                x => 0, y => $y_start,
                height => $y_height - $y_start};
      $table->{row_group}->[$_] = $rg for $y_start .. $y_height - 1;
    }

    ## Step 18
    ## Ending a row group
      ## Step 1
      if ($y_current < $y_height) {
        $onerror->(type => 'rowspan expands table', node => $y_max_node);
      }
      ## Step 2
      while ($y_current < $y_height) {
        ## Step 1
        $growing_downward_growing_cells->();

        ## Step 2
        $y_current++;
      }
      ## Step 3
      @downward_growing_cells = ();

    ## Step 19
    redo ROWS; # Step 12
  } # ROWS
} # form_table

## TODO: Implement scope="" algorithm

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