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