whatpm/Whatpm/HTMLTable.pm

package Whatpm::HTMLTable;
use strict;

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

  ## Step 2
  my $y_max = 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 (1..$x_max) {
      unless ($has_anchored_cell[$_]) {
        if ($table->{column}->[$_]) {
          $onerror->(type => 'column with no anchored cell',
                     node => $table->{column}->[$_]->{element});
        } else {
          $onerror->(type => 'colspan makes column with no anchored cell',
                     node => $column_generated_by[$_]);
        }
      }
    }
  }; # $check_empty_column
  
  ## Step 4
  ## "If the table element has no table children, then return the table (which will be empty), and abort these steps."
  ## ISSUE: What is "table children"?
  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

  ## ISSUE: Step 9.1 /next column/ is not used.

  ## Step 9
  while ($current_ln eq 'colgroup') { # Step 9, Step 9.5
    ## Step 2: 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_max + 1;
      
      ## 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_max] = {element => $current_column} for 1..$span;
      }
      
      ## Step 7
      my $cg = {element => $current_element,
                x => $x_start, y => 1,
                width => $x_max - $x_start - 1}; ## ISSUE: Spec incorrect
      $cg->{width} = $x_max - $x_start + 1;
      $table->{column_group}->[$_] = $cg for $x_start .. $x_max;
    } 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_max += $span;
      
      ## Step 3
      my $cg = {element => $current_element,
                x => $x_max - $span + 1, y => 1,
                width => $span};
      $table->{column_group}->[$_] = $cg for (($x_max - $span + 1) .. $x_max);
    }
    
    ## Step 3, 4
    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 {
    ## Step 1
    return unless @downward_growing_cells;

    ## Step 2
    if ($y_max < $y_current) {
      $y_max++;
      undef $y_max_node;
    }

    ## Step 3
    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_current++;
    
    ## Step 2
    $growing_downward_growing_cells->();
    
    ## Step 3
    my $x_current = 1;

    ## Step 4
    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};
    #return unless @tdth; # redundant with |while| below

    ## Step 5, 16, 17, 18
    ## ISSUE: Step 18 says "step 5 (cells)" while "cells" is step 6.
    while (@tdth) {
      my $current_cell = shift @tdth;
    
      ## Step 6: cells
      $x_current++
        while ($x_current <= $x_max and
               $table->{cell}->[$x_current]->[$y_current]);

      ## Step 7
      if ($x_current > $x_max) {
        $x_max++;
      }

      ## Step 8
      ## ISSUE: How to parse |colspan| is not explicitly specified
      ## (while |span| was).
      ## <http://lists.whatwg.org/pipermail/whatwg-whatwg.org/2006-November/007981.html>
      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 9
      my $rowspan = 1;
      ## ISSUE: How to parse
      ## <http://lists.whatwg.org/pipermail/whatwg-whatwg.org/2006-November/007981.html>
      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 10
      my $cell_grows_downward;
      if ($rowspan == 0) {
        $cell_grows_downward = 1;
        $rowspan = 1;
      }
      
      ## Step 11
      if ($x_max < $x_current + $colspan - 1) { 
        @column_generated_by[$_] = $current_cell
          for $x_max + 1 .. $x_current + $colspan - 1;
        $x_max = $x_current + $colspan - 1;
      }
      
      ## Step 12
      if ($y_max < $y_current + $rowspan - 1) {
        $y_max = $y_current + $rowspan - 1;
        $y_max_node = $current_cell;
      }
      
      ## Step 13
      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 14
      if ($cell_grows_downward) {
        push @downward_growing_cells, [$cell, $x_current, $colspan];
      }
      
      ## Step 15
      $x_current += $colspan;
    }
  }; # $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_max) {
          $onerror->(type => 'rowspan expands table',
                     node => $y_max_node);
        }
        ## 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_max) {
        $onerror->(type => 'rowspan expands table', node => $y_max_node);
      }
      ## Step 2
      while ($y_current < $y_max) {
        ## Step 1
        $y_current++;
        $growing_downward_growing_cells->();
      }
      ## Step 3
      @downward_growing_cells = ();
      
    ## Step 15
    my $y_start = $y_max + 1;

    ## 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_max >= $y_start) {
      my $rg = {element => $current_element,
                x => 1, y => $y_start,
                height => $y_max - $y_start + 1};
      $table->{row_group}->[$_] = $rg for $y_start .. $y_max;
    }

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

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

## TODO: Implement scope="" algorithm

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