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, $must_level) = @_;
  $onerror ||= sub { };
  $must_level ||= 'm';
  
  ## Step 1
  my $x_width = 0;

  ## Step 2
  my $y_height = 0;
  my $y_max_node;

  ## Step 3
  my $pending_tfoot = [];
  
  ## Step 4
  my $table = {
    #caption
    column => [],
    column_group => [],
    row => [], ## NOTE: HTML5 algorithm doesn't associate rows with <tr>s.
    row_group => [],
    cell => [],
    height => 0,
    width => 0,
  };
  
  my @column_has_anchored_cell;
  my @row_has_anchored_cell;
  my @column_generated_by;
  my @row_generated_by;
  
  ## Step 5
  my @table_child = @{$table_el->child_nodes};
  return $table unless @table_child;

  ## Step 6
  for (0..$#table_child) {
    my $el = $table_child[$_];
    next unless $el->node_type == 1; # ELEMENT_NODE
    next unless $el->manakai_local_name eq 'caption';
    my $nsuri = $el->namespace_uri;
    next unless defined $nsuri;
    next unless $nsuri eq q<http://www.w3.org/1999/xhtml>;
    $table->{caption} = {element => $el};
    splice @table_child, $_, 1, ();
    last;
  }

  my $process_row_group;
  my $end = sub {
    ## Step 19 (End)
    for (@$pending_tfoot) {
      $process_row_group->($_);
    }
    
    ## Step 20
    for (0 .. $x_width - 1) {
      unless ($column_has_anchored_cell[$_]) {
        if ($table->{column}->[$_]) {
          $onerror->(type => 'column with no anchored cell',
                     node => $table->{column}->[$_]->{element},
                     level => $must_level);
        } else {
          $onerror->(type => 'colspan creates column with no anchored cell',
                     node => $column_generated_by[$_],
                    level => $must_level);
        }
        last; # only one error.
      }
    }
    for (0 .. $y_height - 1) {
      unless ($row_has_anchored_cell[$_]) {
        if ($table->{row}->[$_]) {
          $onerror->(type => 'row with no anchored cell',
                     node => $table->{row}->[$_]->{element},
                     level => $must_level);
        } else {
          $onerror->(type => 'rowspan creates row with no anchored cell',
                     node => $row_generated_by[$_],
                     level => $must_level);
        }
        last; # only one error.
      }
    }
    
    ## Step 21
    #return $table;
  }; # $end

  ## Step 7, 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;

      redo NEXT_CHILD unless {
        colgroup => 1,
        thead => 1,
        tbody => 1,
        tfoot => 1,
        tr => 1,
      }->{$current_ln};
    } else {
      ## Step 6 2nd paragraph
      $end->();
      $table->{width} = $x_width;
      $table->{height} = $y_height;
      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
        
        ## Step 5 of overall steps 2nd paragraph
        $end->();
        $table->{width} = $x_width;
        $table->{height} = $y_height;
        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;
    $table->{row}->[$y_current] = {element => $tr};
    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;

    ## Step 4
    $growing_downward_growing_cells->();

return unless $current_cell;
## ISSUE: Support for empty <tr></tr> (removed at revision 1376).

    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) {
        @row_generated_by[$_] = $current_cell
            for $y_height .. $y_current + $rowspan - 1;
        $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,
                 };
      $column_has_anchored_cell[$x_current] = 1;
      $row_has_anchored_cell[$y_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,
                       level => $must_level);
            push @{$table->{cell}->[$x]->[$y]}, $cell;
          }
        }
      }

      ## Whether the cell is an empty data cell or not
      if (not $cell->{is_header}) {
        $cell->{is_empty} = 1;
        for my $node (@{$current_cell->child_nodes}) {
          my $nt = $node->node_type;
          if ($nt == 3 or $nt == 4) { # TEXT_NODE / CDATA_SECTION_NODE
            if ($node->data =~ /\P{Zs}/) { ## TOOD: non-Zs class
              delete $cell->{is_empty};
              last;
            }
          } elsif ($nt == 1) { # ELEMENT_NODE
            delete $cell->{is_empty};
            last;
          }
        }
        ## NOTE: Entity references are not supported
      }
      
      ## 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

  $process_row_group = sub ($) {
    ## Step 1
    my $y_start = $y_height;

    ## Step 2
    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'
    } @{$_[0]->child_nodes}) {
      $process_row->($_);
    }

    ## Step 3
    if ($y_height > $y_start) {
      my $rg = {element => $current_element, ## ISSUE: "element being processed"?
                x => 0, y => $y_start,
                height => $y_height - $y_start};
      $table->{row_group}->[$_] = $rg for $y_start .. $y_height - 1;
    }

    ## Step 4
    ## Ending a row group
      ## Step 1
      while ($y_current < $y_height) {
        ## Step 1
        $growing_downward_growing_cells->();

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

  ## 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 6 2nd paragraph
        $end->();
        $table->{width} = $x_width;
        $table->{height} = $y_height;
        return $table;
      }
    } # NEXT_CHILD

    ## Step 13
    if ($current_ln eq 'tr') {
      $process_row->($current_element);
      # advance (done at the first of ROWS)
      redo ROWS;
    }

    ## Step 14
    ## Ending a row group
      ## Step 1
      while ($y_current < $y_height) {
        ## Step 1
        $growing_downward_growing_cells->();

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

    ## Step 15
    if ($current_ln eq 'tfoot') {
      push @$pending_tfoot, $current_element;
      # advance (done at the top of ROWS)
      redo ROWS;
    }

    ## Step 16
    # thead or tbody
    $process_row_group->($current_element);

    ## Step 17
    # Advance (done at the top of ROWS).

    ## Step 18
    redo ROWS;
  } # ROWS

  $end->();
  $table->{width} = $x_width;
  $table->{height} = $y_height;
  return $table;
} # form_table

sub assign_header ($$;$$) {
  my (undef, $table, $onerror, $must_level) = @_;
  $onerror ||= sub { };
  $must_level ||= 'm';

  my $assign_header = sub ($$$) {
    my $_cell = shift;
    my ($x, $y) = @_;

    for my $__cell (@{$_cell or []}) {
      if ($__cell and $__cell->{element} and
          not $__cell->{is_header} and
          not $__cell->{element}->has_attribute_ns (undef, 'headers')) {
        $__cell->{header}->{$x}->{$y} = 1;
      }
    }
  }; # $assign_header

  for my $x (0 .. $table->{width} - 1) {
    for my $y (0 .. $table->{height} - 1) {
      my $cell = $table->{cell}->[$x]->[$y];
      $cell = $cell->[0] if $cell; # anchored cell is always ->{cell}[][][0].
      next if $cell->{x} != $x;
      next if $cell->{y} != $y;
      if ($cell) {
        if ($cell->{is_header}) {
          my $scope = $cell->{element}->get_attribute_ns (undef, 'scope');
          $scope = $scope ? lc $scope : ''; ## TODO: case
          if ($scope eq 'row') {
            for my $_x ($x + $cell->{width} .. $table->{width} - 1) {
              for my $_y ($y .. $y + $cell->{height} - 1) {
                $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
              }
            }
          } elsif ($scope eq 'col') {
            for my $_x ($x .. $x + $cell->{width} - 1) {
              for my $_y ($y .. $table->{height} - 1) {
                $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
              }
            }
          } elsif ($scope eq 'rowgroup') {
            ## NOTE: A cell cannot exceed across a row group boundary.
            if ($table->{row_group}->[$y] and
                $table->{row_group}->[$y]->{height}) {
              for my $_x ($x .. $table->{width} - 1) {
                for my $_y ($y ..
                            $table->{row_group}->[$y]->{y} +
                            $table->{row_group}->[$y]->{height} - 1) {
                  $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
                }
              }
            }
            ## TODO: Should we raise a warning?
          } elsif ($scope eq 'colgroup') {
            if ($table->{column_group}->[$x] and
                $table->{column_group}->{width} and
                $table->{column_group}->[$x]->{x} == $x) { # anchored
              for my $_x ($x .. 
                          $table->{column_group}->[$x]->{x} + 
                          $table->{column_group}->[$x]->{width} - 1) {
                for my $_y ($y .. $table->{height} - 1) {
                  $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
                }
              }
            }
            ## TODO: Warning?
          } else { # auto
            ## 1.
            my $header_width = $cell->{width};
            W: for ($x + $cell->{width} .. $table->{width} - 1) {
              my $_cell = $table->{cell}->[$_]->[$y];
              for (@{$_cell or []}) {
                if ($_->{element} and not $_->{is_empty}) {
                  last W; # not empty
                }
              }
              $header_width++;
            } # W

            ## 2.
            my $_x = $x + $header_width;

            ## 3.
            HORIZONTAL: {
              last HORIZONTAL if $_x == $table->{width}; # goto Vertical

              ## 4. # goto Vertical
              last HORIZONTAL
                  if $table->{cell}->[$_x]->[$y] and
                      $table->{cell}->[$_x]->[$y]->[0] and # anchored
                      $table->{cell}->[$_x]->[$y]->[0]->{is_header};

              ## 5.
              for my $_y ($y .. $y + $cell->{height} - 1) {
                $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
              }

              ## 6.
              $_x++;

              ## 7.
              redo HORIZONTAL;
            } # HORIZONTAL

            ## 8. Vertical
            my $_y = $y + $cell->{height};

            VERTICAL: {
              ## 9. # goto END
              last VERTICAL if $_y == $table->{height};

              ## 10.
              if ($table->{cell}->[$x]->[$_y]) {
                my $h_cell = $table->{cell}->[$x]->[$_y]->[0]; # anchored cell
                if ($h_cell and $h_cell->{is_header}) {
                  ## 10.1.
                  my $width = $h_cell->{width};
                  W: for ($h_cell->{x} + $width .. $table->{width} - 1) {
                    my $_cell = $table->{cell}->[$_]->[$y];
                    for (@{$_cell or []}) {
                      if ($_->{element} and not $_->{is_empty}) {
                        last W; # not empty
                      }
                    }
                    $width++;
                  } # W
                    
                  ## 10.2. # goto end
                  last VERTICAL if $width == $header_width;
                } # 10.
              }

              ## 11.
              for my $_x ($x .. $x + $header_width - 1) {
                $assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
              }

              ## 12.
              $_y++;

              ## 13. # goto vertical (wrong)
              redo VERTICAL;
            } # VERTICAL

            ## 14. End
            # (we have already done)
          }
        } else { # data cell
          
        }
      }
    }
  }


  ## NOTE: The "tree order" constraints in the spec algorithm are irrelevant
  ## in fact.
} # assign_header

1;
## $Date: 2008/05/05 08:36:55 $
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, $must_level) = @_;
7	$onerror \|\|= sub { };
8	$must_level \|\|= 'm';
9
10	## Step 1
11	my $x_width = 0;
12
13	## Step 2
14	my $y_height = 0;
15	my $y_max_node;
16
17	## Step 3
18	my $pending_tfoot = [];
19
20	## Step 4
21	my $table = {
22	#caption
23	column => [],
24	column_group => [],
25	row => [], ## NOTE: HTML5 algorithm doesn't associate rows with <tr>s.
26	row_group => [],
27	cell => [],
28	height => 0,
29	width => 0,
30	};
31
32	my @column_has_anchored_cell;
33	my @row_has_anchored_cell;
34	my @column_generated_by;
35	my @row_generated_by;
36
37	## Step 5
38	my @table_child = @{$table_el->child_nodes};
39	return $table unless @table_child;
40
41	## Step 6
42	for (0..$#table_child) {
43	my $el = $table_child[$_];
44	next unless $el->node_type == 1; # ELEMENT_NODE
45	next unless $el->manakai_local_name eq 'caption';
46	my $nsuri = $el->namespace_uri;
47	next unless defined $nsuri;
48	next unless $nsuri eq q<http://www.w3.org/1999/xhtml>;
49	$table->{caption} = {element => $el};
50	splice @table_child, $_, 1, ();
51	last;
52	}
53
54	my $process_row_group;
55	my $end = sub {
56	## Step 19 (End)
57	for (@$pending_tfoot) {
58	$process_row_group->($_);
59	}
60
61	## Step 20
62	for (0 .. $x_width - 1) {
63	unless ($column_has_anchored_cell[$_]) {
64	if ($table->{column}->[$_]) {
65	$onerror->(type => 'column with no anchored cell',
66	node => $table->{column}->[$_]->{element},
67	level => $must_level);
68	} else {
69	$onerror->(type => 'colspan creates column with no anchored cell',
70	node => $column_generated_by[$_],
71	level => $must_level);
72	}
73	last; # only one error.
74	}
75	}
76	for (0 .. $y_height - 1) {
77	unless ($row_has_anchored_cell[$_]) {
78	if ($table->{row}->[$_]) {
79	$onerror->(type => 'row with no anchored cell',
80	node => $table->{row}->[$_]->{element},
81	level => $must_level);
82	} else {
83	$onerror->(type => 'rowspan creates row with no anchored cell',
84	node => $row_generated_by[$_],
85	level => $must_level);
86	}
87	last; # only one error.
88	}
89	}
90
91	## Step 21
92	#return $table;
93	}; # $end
94
95	## Step 7, 8
96	my $current_element;
97	my $current_ln;
98	NEXT_CHILD: {
99	$current_element = shift @table_child;
100	if (defined $current_element) {
101	redo NEXT_CHILD unless $current_element->node_type == 1;
102	my $nsuri = $current_element->namespace_uri;
103	redo NEXT_CHILD unless defined $nsuri and
104	$nsuri eq q<http://www.w3.org/1999/xhtml>;
105	$current_ln = $current_element->manakai_local_name;
106
107	redo NEXT_CHILD unless {
108	colgroup => 1,
109	thead => 1,
110	tbody => 1,
111	tfoot => 1,
112	tr => 1,
113	}->{$current_ln};
114	} else {
115	## Step 6 2nd paragraph
116	$end->();
117	$table->{width} = $x_width;
118	$table->{height} = $y_height;
119	return $table;
120	}
121	} # NEXT_CHILD
122
123	## Step 9
124	while ($current_ln eq 'colgroup') { # Step 9, Step 9.4
125	## Step 9.1: column groups
126	my @col = grep {
127	$_->node_type == 1 and
128	defined $_->namespace_uri and
129	$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
130	$_->manakai_local_name eq 'col'
131	} @{$current_element->child_nodes};
132	if (@col) {
133	## Step 1
134	my $x_start = $x_width;
135
136	## Step 2, 6
137	while (@col) {
138	my $current_column = shift @col;
139
140	## Step 3: columns
141	my $span = 1;
142	my $col_span = $current_column->get_attribute_ns (undef, 'span');
143	## Parse non-negative integer
144	if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
145	$span = $1 \|\| 1;
146	}
147	## ISSUE: If span=0, what is /span/ value?
148
149	## Step 4, 5
150	$table->{column}->[$x_width++] = {element => $current_column}
151	for 1..$span;
152	}
153
154	## Step 7
155	my $cg = {element => $current_element,
156	x => $x_start, y => 0,
157	width => $x_width - $x_start};
158	$table->{column_group}->[$_] = $cg for $x_start .. $x_width - 1;
159	} else { # no <col> children
160	## Step 1
161	my $span = 1;
162	my $col_span = $current_element->get_attribute_ns (undef, 'span');
163	## Parse non-negative integer
164	if (defined $col_span and $col_span =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
165	$span = $1 \|\| 1;
166	}
167	## ISSUE: If span=0, what is /span/ value?
168
169	## Step 2
170	$x_width += $span;
171
172	## Step 3
173	my $cg = {element => $current_element,
174	x => $x_width - $span, y => 0,
175	width => $span};
176	$table->{column_group}->[$_] = $cg for $cg->{x} .. $x_width - 1;
177	}
178
179	## Step 9.2, 9.3
180	NEXT_CHILD: {
181	$current_element = shift @table_child;
182	if (defined $current_element) {
183	redo NEXT_CHILD unless $current_element->node_type == 1;
184	my $nsuri = $current_element->namespace_uri;
185	redo NEXT_CHILD unless defined $nsuri and
186	$nsuri eq q<http://www.w3.org/1999/xhtml>;
187	$current_ln = $current_element->manakai_local_name;
188
189	redo NEXT_CHILD unless {
190	colgroup => 1,
191	thead => 1,
192	tbody => 1,
193	tfoot => 1,
194	tr => 1,
195	}->{$current_ln};
196	} else {
197	## End of subsection
198
199	## Step 5 of overall steps 2nd paragraph
200	$end->();
201	$table->{width} = $x_width;
202	$table->{height} = $y_height;
203	return $table;
204	}
205	} # NEXT_CHILD
206	}
207
208	## Step 10
209	my $y_current = 0;
210
211	## Step 11
212	my @downward_growing_cells;
213
214	my $growing_downward_growing_cells = sub {
215	for (@downward_growing_cells) {
216	for my $x ($_->[1] .. ($_->[1] + $_->[2] - 1)) {
217	$table->{cell}->[$x]->[$y_current] = [$_->[0]];
218	$_->[0]->{height}++;
219	}
220	}
221	}; # $growing_downward_growing_cells
222
223	my $process_row = sub {
224	## Step 1
225	$y_height++ if $y_height == $y_current;
226
227	## Step 2
228	my $x_current = 0;
229
230	## Step 3
231	my $tr = shift;
232	$table->{row}->[$y_current] = {element => $tr};
233	my @tdth = grep {
234	$_->node_type == 1 and
235	defined $_->namespace_uri and
236	$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
237	{td => 1, th => 1}->{$_->manakai_local_name}
238	} @{$tr->child_nodes};
239	my $current_cell = shift @tdth;
240
241	## Step 4
242	$growing_downward_growing_cells->();
243
244	return unless $current_cell;
245	## ISSUE: Support for empty <tr></tr> (removed at revision 1376).
246
247	CELL: while (1) {
248	## Step 5: cells
249	$x_current++
250	while ($x_current < $x_width and
251	$table->{cell}->[$x_current]->[$y_current]);
252
253	## Step 6
254	$x_width++ if $x_current == $x_width;
255
256	## Step 7
257	my $colspan = 1;
258	my $attr_value = $current_cell->get_attribute_ns (undef, 'colspan');
259	if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
260	$colspan = $1 \|\| 1;
261	}
262
263	## Step 8
264	my $rowspan = 1;
265	my $attr_value = $current_cell->get_attribute_ns (undef, 'rowspan');
266	if (defined $attr_value and $attr_value =~ /^[\x09-\x0D\x20]*([0-9]+)/) {
267	$rowspan = $1;
268	}
269
270	## Step 9
271	my $cell_grows_downward;
272	if ($rowspan == 0) {
273	$cell_grows_downward = 1;
274	$rowspan = 1;
275	}
276
277	## Step 10
278	if ($x_width < $x_current + $colspan) {
279	@column_generated_by[$_] = $current_cell
280	for $x_width .. $x_current + $colspan - 1;
281	$x_width = $x_current + $colspan;
282	}
283
284	## Step 11
285	if ($y_height < $y_current + $rowspan) {
286	@row_generated_by[$_] = $current_cell
287	for $y_height .. $y_current + $rowspan - 1;
288	$y_height = $y_current + $rowspan;
289	$y_max_node = $current_cell;
290	}
291
292	## Step 12
293	my $cell = {
294	is_header => ($current_cell->manakai_local_name eq 'th'),
295	element => $current_cell,
296	x => $x_current, y => $y_current,
297	width => $colspan, height => $rowspan,
298	};
299	$column_has_anchored_cell[$x_current] = 1;
300	$row_has_anchored_cell[$y_current] = 1;
301	for my $x ($x_current .. ($x_current + $colspan - 1)) {
302	for my $y ($y_current .. ($y_current + $rowspan - 1)) {
303	unless ($table->{cell}->[$x]->[$y]) {
304	$table->{cell}->[$x]->[$y] = [$cell];
305	} else {
306	$onerror->(type => "cell overlapping:$x:$y", node => $current_cell,
307	level => $must_level);
308	push @{$table->{cell}->[$x]->[$y]}, $cell;
309	}
310	}
311	}
312
313	## Whether the cell is an empty data cell or not
314	if (not $cell->{is_header}) {
315	$cell->{is_empty} = 1;
316	for my $node (@{$current_cell->child_nodes}) {
317	my $nt = $node->node_type;
318	if ($nt == 3 or $nt == 4) { # TEXT_NODE / CDATA_SECTION_NODE
319	if ($node->data =~ /\P{Zs}/) { ## TOOD: non-Zs class
320	delete $cell->{is_empty};
321	last;
322	}
323	} elsif ($nt == 1) { # ELEMENT_NODE
324	delete $cell->{is_empty};
325	last;
326	}
327	}
328	## NOTE: Entity references are not supported
329	}
330
331	## Step 13
332	if ($cell_grows_downward) {
333	push @downward_growing_cells, [$cell, $x_current, $colspan];
334	}
335
336	## Step 14
337	$x_current += $colspan;
338
339	## Step 15-17
340	$current_cell = shift @tdth;
341	if (defined $current_cell) {
342	## Step 16-17
343	#
344	} else {
345	## Step 15
346	$y_current++;
347	last CELL;
348	}
349	} # CELL
350	}; # $process_row
351
352	$process_row_group = sub ($) {
353	## Step 1
354	my $y_start = $y_height;
355
356	## Step 2
357	for (grep {
358	$_->node_type == 1 and
359	defined $_->namespace_uri and
360	$_->namespace_uri eq q<http://www.w3.org/1999/xhtml> and
361	$_->manakai_local_name eq 'tr'
362	} @{$_[0]->child_nodes}) {
363	$process_row->($_);
364	}
365
366	## Step 3
367	if ($y_height > $y_start) {
368	my $rg = {element => $current_element, ## ISSUE: "element being processed"?
369	x => 0, y => $y_start,
370	height => $y_height - $y_start};
371	$table->{row_group}->[$_] = $rg for $y_start .. $y_height - 1;
372	}
373
374	## Step 4
375	## Ending a row group
376	## Step 1
377	while ($y_current < $y_height) {
378	## Step 1
379	$growing_downward_growing_cells->();
380
381	## Step 2
382	$y_current++;
383	}
384	## Step 2
385	@downward_growing_cells = ();
386	}; # $process_row_group
387
388	## Step 12: rows
389	unshift @table_child, $current_element;
390	ROWS: {
391	NEXT_CHILD: {
392	$current_element = shift @table_child;
393	if (defined $current_element) {
394	redo NEXT_CHILD unless $current_element->node_type == 1;
395	my $nsuri = $current_element->namespace_uri;
396	redo NEXT_CHILD unless defined $nsuri and
397	$nsuri eq q<http://www.w3.org/1999/xhtml>;
398	$current_ln = $current_element->manakai_local_name;
399
400	redo NEXT_CHILD unless {
401	thead => 1,
402	tbody => 1,
403	tfoot => 1,
404	tr => 1,
405	}->{$current_ln};
406	} else {
407	## Step 6 2nd paragraph
408	$end->();
409	$table->{width} = $x_width;
410	$table->{height} = $y_height;
411	return $table;
412	}
413	} # NEXT_CHILD
414
415	## Step 13
416	if ($current_ln eq 'tr') {
417	$process_row->($current_element);
418	# advance (done at the first of ROWS)
419	redo ROWS;
420	}
421
422	## Step 14
423	## Ending a row group
424	## Step 1
425	while ($y_current < $y_height) {
426	## Step 1
427	$growing_downward_growing_cells->();
428
429	## Step 2
430	$y_current++;
431	}
432	## Step 2
433	@downward_growing_cells = ();
434
435	## Step 15
436	if ($current_ln eq 'tfoot') {
437	push @$pending_tfoot, $current_element;
438	# advance (done at the top of ROWS)
439	redo ROWS;
440	}
441
442	## Step 16
443	# thead or tbody
444	$process_row_group->($current_element);
445
446	## Step 17
447	# Advance (done at the top of ROWS).
448
449	## Step 18
450	redo ROWS;
451	} # ROWS
452
453	$end->();
454	$table->{width} = $x_width;
455	$table->{height} = $y_height;
456	return $table;
457	} # form_table
458
459	sub assign_header ($$;$$) {
460	my (undef, $table, $onerror, $must_level) = @_;
461	$onerror \|\|= sub { };
462	$must_level \|\|= 'm';
463
464	my $assign_header = sub ($$$) {
465	my $_cell = shift;
466	my ($x, $y) = @_;
467
468	for my $__cell (@{$_cell or []}) {
469	if ($__cell and $__cell->{element} and
470	not $__cell->{is_header} and
471	not $__cell->{element}->has_attribute_ns (undef, 'headers')) {
472	$__cell->{header}->{$x}->{$y} = 1;
473	}
474	}
475	}; # $assign_header
476
477	for my $x (0 .. $table->{width} - 1) {
478	for my $y (0 .. $table->{height} - 1) {
479	my $cell = $table->{cell}->[$x]->[$y];
480	$cell = $cell->[0] if $cell; # anchored cell is always ->{cell}[][][0].
481	next if $cell->{x} != $x;
482	next if $cell->{y} != $y;
483	if ($cell) {
484	if ($cell->{is_header}) {
485	my $scope = $cell->{element}->get_attribute_ns (undef, 'scope');
486	$scope = $scope ? lc $scope : ''; ## TODO: case
487	if ($scope eq 'row') {
488	for my $_x ($x + $cell->{width} .. $table->{width} - 1) {
489	for my $_y ($y .. $y + $cell->{height} - 1) {
490	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
491	}
492	}
493	} elsif ($scope eq 'col') {
494	for my $_x ($x .. $x + $cell->{width} - 1) {
495	for my $_y ($y .. $table->{height} - 1) {
496	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
497	}
498	}
499	} elsif ($scope eq 'rowgroup') {
500	## NOTE: A cell cannot exceed across a row group boundary.
501	if ($table->{row_group}->[$y] and
502	$table->{row_group}->[$y]->{height}) {
503	for my $_x ($x .. $table->{width} - 1) {
504	for my $_y ($y ..
505	$table->{row_group}->[$y]->{y} +
506	$table->{row_group}->[$y]->{height} - 1) {
507	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
508	}
509	}
510	}
511	## TODO: Should we raise a warning?
512	} elsif ($scope eq 'colgroup') {
513	if ($table->{column_group}->[$x] and
514	$table->{column_group}->{width} and
515	$table->{column_group}->[$x]->{x} == $x) { # anchored
516	for my $_x ($x ..
517	$table->{column_group}->[$x]->{x} +
518	$table->{column_group}->[$x]->{width} - 1) {
519	for my $_y ($y .. $table->{height} - 1) {
520	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
521	}
522	}
523	}
524	## TODO: Warning?
525	} else { # auto
526	## 1.
527	my $header_width = $cell->{width};
528	W: for ($x + $cell->{width} .. $table->{width} - 1) {
529	my $_cell = $table->{cell}->[$_]->[$y];
530	for (@{$_cell or []}) {
531	if ($_->{element} and not $_->{is_empty}) {
532	last W; # not empty
533	}
534	}
535	$header_width++;
536	} # W
537
538	## 2.
539	my $_x = $x + $header_width;
540
541	## 3.
542	HORIZONTAL: {
543	last HORIZONTAL if $_x == $table->{width}; # goto Vertical
544
545	## 4. # goto Vertical
546	last HORIZONTAL
547	if $table->{cell}->[$_x]->[$y] and
548	$table->{cell}->[$_x]->[$y]->[0] and # anchored
549	$table->{cell}->[$_x]->[$y]->[0]->{is_header};
550
551	## 5.
552	for my $_y ($y .. $y + $cell->{height} - 1) {
553	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
554	}
555
556	## 6.
557	$_x++;
558
559	## 7.
560	redo HORIZONTAL;
561	} # HORIZONTAL
562
563	## 8. Vertical
564	my $_y = $y + $cell->{height};
565
566	VERTICAL: {
567	## 9. # goto END
568	last VERTICAL if $_y == $table->{height};
569
570	## 10.
571	if ($table->{cell}->[$x]->[$_y]) {
572	my $h_cell = $table->{cell}->[$x]->[$_y]->[0]; # anchored cell
573	if ($h_cell and $h_cell->{is_header}) {
574	## 10.1.
575	my $width = $h_cell->{width};
576	W: for ($h_cell->{x} + $width .. $table->{width} - 1) {
577	my $_cell = $table->{cell}->[$_]->[$y];
578	for (@{$_cell or []}) {
579	if ($_->{element} and not $_->{is_empty}) {
580	last W; # not empty
581	}
582	}
583	$width++;
584	} # W
585
586	## 10.2. # goto end
587	last VERTICAL if $width == $header_width;
588	} # 10.
589	}
590
591	## 11.
592	for my $_x ($x .. $x + $header_width - 1) {
593	$assign_header->($table->{cell}->[$_x]->[$_y] => $x, $y);
594	}
595
596	## 12.
597	$_y++;
598
599	## 13. # goto vertical (wrong)
600	redo VERTICAL;
601	} # VERTICAL
602
603	## 14. End
604	# (we have already done)
605	}
606	} else { # data cell
607
608	}
609	}
610	}
611	}
612
613
614	## NOTE: The "tree order" constraints in the spec algorithm are irrelevant
615	## in fact.
616	} # assign_header
617
618	1;
619	## $Date: 2008/05/05 08:36:55 $