2004/html/mkcontbl.pl

#!/usr/bin/perl
use strict;
require 'html-content.pl';
our $LIST;

use Getopt::Long;
use Pod::Usage;
my $target = 'pre';
my %argv;
GetOptions (
  q<help> => \$argv{help},
  q<no-transitional> => \$argv{'no-transitional'},
  q<no-strict> => \$argv{'no-strict'},
  q<no-frameset> => \$argv{'no-frameset'},
  q<element-type=s> => \$target,
) or pod2usage (2);
pod2usage (-exitval => 0, -verbose => 1) if $argv{help};

sub is_element ($) {
  my ($value) = @_;
  $value =~ /[%A-Z]/ ? 0 : 1;
}

my $OK = 'O';
my $NG = 'X';

sub mark (%);
sub mark (%) {
  my %opt = @_;
  my @member;
  push @member, split /[\s|]+/, $opt{$_}->{$opt{class}} for @{$opt{member}};
  ELEMENT: for my $element (@member) {
    if (is_element $element) {
      for (@{$opt{table}}) {
        if ($_->[0] eq $element) {
          $_->[-1] = $opt{mark};
          next ELEMENT;
        }
      }
      my $row = [$element];
      for (my $i = $#{$opt{table}->[0]} - 1; $i > 0; $i--) {
        push @$row, '-1';
      }
      push @$row, $opt{mark};
      push @{$opt{table}}, $row;
    } else {
      mark %opt,
           class => $element,
           member => [qw/list list2/];
    }
  }
}

sub add (%) {
  my (%opt) = @_;
  push @{$opt{table}->[0]}, $opt{name};
  push @{$opt{table}->[$_]}, '-1' for 1..$#{$opt{table}};
  mark %opt, mark => $OK, class => $opt{target},
       member => [qw/list list2 plus/];
  mark %opt, mark => $NG, class => $opt{target},
       member => [qw/minus/];
}

sub element ($) {
  my $el = shift;
  if ($el =~ /[A-Z%]/) {
    qq<<code>$el</code>>;
  } else {
    qq<<code class="HTMLe">$el</code>>;
  }
}

sub serialize ($$) {
  my ($tbl, $span) = @_;
  my $r = q<<table border><thead><tr>>;
  $r .= join '', map {qq<<th>$_</th>>} @{$tbl->[0]};
  $r .= q<</tr></thead><tbody>>;
  for my $i (1..$#$tbl) {
    $r .= q<<tr>>;
    $r .= q<<th>>.element ($tbl->[$i]->[0]).q<</th>>;
    for my $j (1..$#{$tbl->[$i]}) {
      if ($tbl->[$i]->[$j]) {
        $r .= q{<td};
        $r .= q< rowspan=">.$span->[$i]->[$j]->{row}.q<"> if $span->[$i]->[$j]->{row};
        $r .= q< colspan=">.$span->[$i]->[$j]->{col}.q<"> if $span->[$i]->[$j]->{col};
        $r .= q{>};
        $r .= element ($tbl->[$i]->[$j]) || '-' unless $tbl->[$i]->[$j] eq '-1';
        $r .= q<</td>>;
      }
    }
    $r .= qq<</tr>\n>;
  }
  $r .= qq<</tbody></table>\n>;
  $r;
}

sub equal ($$) {
  my ($x, $y) = @_;
  return $x eq $y;
}

sub merge_row ($$) {
  my ($tbl, $span) = @_;
  for my $i (1..($#$tbl-1)) {
    for my $j (1..$#{$tbl->[$i]}) {
      if ($tbl->[$i]->[$j]) {
        my $s = 1;
        for my $ii (($i+1)..$#$tbl) {
          if ($tbl->[$ii]->[$j] and
              $span->[$i]->[$j]->{col} == $span->[$ii]->[$j]->{col} and
              equal $tbl->[$i]->[$j] => $tbl->[$ii]->[$j]) {
            $s++;
            $tbl->[$ii]->[$j] = 0;
          } else {
            last;
          }
        }
        $span->[$i]->[$j]->{row} = $s if $s > 1;
      }
    }
  }
}

sub merge_col ($$) {
  my ($tbl, $span) = @_;
  for my $i (1..$#$tbl) {
    for my $j (1..($#{$tbl->[$i]}-1)) {
      if ($tbl->[$i]->[$j]) {
        my $s = 1;
        for my $jj (($j+1)..$#{$tbl->[$i]}) {
          if ($tbl->[$i]->[$jj] and
              $span->[$i]->[$j]->{row} == $span->[$i]->[$jj]->{row} and
              equal $tbl->[$i]->[$j] => $tbl->[$i]->[$jj]) {
            $s++;
            $tbl->[$i]->[$jj] = 0;
          } else {
            last;
          }
        }
        $span->[$i]->[$j]->{col} = $s if $s > 1;
      }
    }
  }
}

my $tbl = [['']];
my @span;

for (@$LIST) {
  next if $argv{'no-strict'} and $_->{name} =~ /Strict|ISO-HTML|XHTML 1.1/
                                   and not $_->{name} =~ /Legacy/;
  next if $argv{'no-transitional'} and $_->{name} =~ /Transitional|Legacy/
                                   and not $_->{name} =~ /Frameset/;
  next if $argv{'no-frameset'} and $_->{name} =~ /Frameset/
                                   and not $_->{name} =~ /Transitional/;
  add target => $target, table => $tbl, name => $_->{name},
      list => $_->{class}, list2 => $_->{class_misc},
      plus => $_->{plus}, minus => $_->{minus};
}
merge_col $tbl, \@span;
merge_row $tbl, \@span;

print STDOUT qq<<!DOCTYPE table SYSTEM>\n>;
print STDOUT serialize $tbl, \@span;

=head1 NAME

mkclstbl - HTML Element Type Class History Table Generator

=head1 SYNOPSIS

  mkclstbl.pl [--no-strict] [--no-transitional] [--no-frameset] > table.html
  mkclstbl.pl --help

=head1 DESCRIPTION

This script generates an HTML table that describes what element type belongs
what element class(es) in versions of HTML.

=head1 OPTIONS

This script has four arguments:

=over 4

=item --help

Show help message.

=item --no-frameset

Omit some columns that describes Frameset DTDs.

=item --no-strict

Omit some columns that describes Strict DTDs, ISO-HTML, XHTML 1.1 or
XHTML m12n Abstract Modules.

=item --no-transitional

Omit some columns that describes Transitional DTDs.

=back

=head1 SEE ALSO

HTML Specifications and DTDs.

<http://suika.fam.cx/www/2004/html/>.

=head1 LICENSE

Copyright 2004 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

# $Date: 2004/07/03 06:24:06 $
1	#!/usr/bin/perl
2	use strict;
3	require 'html-content.pl';
4	our $LIST;
5
6	use Getopt::Long;
7	use Pod::Usage;
8	my $target = 'pre';
9	my %argv;
10	GetOptions (
11	q<help> => \$argv{help},
12	q<no-transitional> => \$argv{'no-transitional'},
13	q<no-strict> => \$argv{'no-strict'},
14	q<no-frameset> => \$argv{'no-frameset'},
15	q<element-type=s> => \$target,
16	) or pod2usage (2);
17	pod2usage (-exitval => 0, -verbose => 1) if $argv{help};
18
19	sub is_element ($) {
20	my ($value) = @_;
21	$value =~ /[%A-Z]/ ? 0 : 1;
22	}
23
24	my $OK = 'O';
25	my $NG = 'X';
26
27	sub mark (%);
28	sub mark (%) {
29	my %opt = @_;
30	my @member;
31	push @member, split /[\s\|]+/, $opt{$_}->{$opt{class}} for @{$opt{member}};
32	ELEMENT: for my $element (@member) {
33	if (is_element $element) {
34	for (@{$opt{table}}) {
35	if ($_->[0] eq $element) {
36	$_->[-1] = $opt{mark};
37	next ELEMENT;
38	}
39	}
40	my $row = [$element];
41	for (my $i = $#{$opt{table}->[0]} - 1; $i > 0; $i--) {
42	push @$row, '-1';
43	}
44	push @$row, $opt{mark};
45	push @{$opt{table}}, $row;
46	} else {
47	mark %opt,
48	class => $element,
49	member => [qw/list list2/];
50	}
51	}
52	}
53
54	sub add (%) {
55	my (%opt) = @_;
56	push @{$opt{table}->[0]}, $opt{name};
57	push @{$opt{table}->[$_]}, '-1' for 1..$#{$opt{table}};
58	mark %opt, mark => $OK, class => $opt{target},
59	member => [qw/list list2 plus/];
60	mark %opt, mark => $NG, class => $opt{target},
61	member => [qw/minus/];
62	}
63
64	sub element ($) {
65	my $el = shift;
66	if ($el =~ /[A-Z%]/) {
67	qq<<code>$el</code>>;
68	} else {
69	qq<<code class="HTMLe">$el</code>>;
70	}
71	}
72
73	sub serialize ($$) {
74	my ($tbl, $span) = @_;
75	my $r = q<<table border><thead><tr>>;
76	$r .= join '', map {qq<<th>$_</th>>} @{$tbl->[0]};
77	$r .= q<</tr></thead><tbody>>;
78	for my $i (1..$#$tbl) {
79	$r .= q<<tr>>;
80	$r .= q<<th>>.element ($tbl->[$i]->[0]).q<</th>>;
81	for my $j (1..$#{$tbl->[$i]}) {
82	if ($tbl->[$i]->[$j]) {
83	$r .= q{<td};
84	$r .= q< rowspan=">.$span->[$i]->[$j]->{row}.q<"> if $span->[$i]->[$j]->{row};
85	$r .= q< colspan=">.$span->[$i]->[$j]->{col}.q<"> if $span->[$i]->[$j]->{col};
86	$r .= q{>};
87	$r .= element ($tbl->[$i]->[$j]) \|\| '-' unless $tbl->[$i]->[$j] eq '-1';
88	$r .= q<</td>>;
89	}
90	}
91	$r .= qq<</tr>\n>;
92	}
93	$r .= qq<</tbody></table>\n>;
94	$r;
95	}
96
97	sub equal ($$) {
98	my ($x, $y) = @_;
99	return $x eq $y;
100	}
101
102	sub merge_row ($$) {
103	my ($tbl, $span) = @_;
104	for my $i (1..($#$tbl-1)) {
105	for my $j (1..$#{$tbl->[$i]}) {
106	if ($tbl->[$i]->[$j]) {
107	my $s = 1;
108	for my $ii (($i+1)..$#$tbl) {
109	if ($tbl->[$ii]->[$j] and
110	$span->[$i]->[$j]->{col} == $span->[$ii]->[$j]->{col} and
111	equal $tbl->[$i]->[$j] => $tbl->[$ii]->[$j]) {
112	$s++;
113	$tbl->[$ii]->[$j] = 0;
114	} else {
115	last;
116	}
117	}
118	$span->[$i]->[$j]->{row} = $s if $s > 1;
119	}
120	}
121	}
122	}
123
124	sub merge_col ($$) {
125	my ($tbl, $span) = @_;
126	for my $i (1..$#$tbl) {
127	for my $j (1..($#{$tbl->[$i]}-1)) {
128	if ($tbl->[$i]->[$j]) {
129	my $s = 1;
130	for my $jj (($j+1)..$#{$tbl->[$i]}) {
131	if ($tbl->[$i]->[$jj] and
132	$span->[$i]->[$j]->{row} == $span->[$i]->[$jj]->{row} and
133	equal $tbl->[$i]->[$j] => $tbl->[$i]->[$jj]) {
134	$s++;
135	$tbl->[$i]->[$jj] = 0;
136	} else {
137	last;
138	}
139	}
140	$span->[$i]->[$j]->{col} = $s if $s > 1;
141	}
142	}
143	}
144	}
145
146	my $tbl = [['']];
147	my @span;
148
149	for (@$LIST) {
150	next if $argv{'no-strict'} and $_->{name} =~ /Strict\|ISO-HTML\|XHTML 1.1/
151	and not $_->{name} =~ /Legacy/;
152	next if $argv{'no-transitional'} and $_->{name} =~ /Transitional\|Legacy/
153	and not $_->{name} =~ /Frameset/;
154	next if $argv{'no-frameset'} and $_->{name} =~ /Frameset/
155	and not $_->{name} =~ /Transitional/;
156	add target => $target, table => $tbl, name => $_->{name},
157	list => $_->{class}, list2 => $_->{class_misc},
158	plus => $_->{plus}, minus => $_->{minus};
159	}
160	merge_col $tbl, \@span;
161	merge_row $tbl, \@span;
162
163	print STDOUT qq<<!DOCTYPE table SYSTEM>\n>;
164	print STDOUT serialize $tbl, \@span;
165
166	=head1 NAME
167
168	mkclstbl - HTML Element Type Class History Table Generator
169
170	=head1 SYNOPSIS
171
172	mkclstbl.pl [--no-strict] [--no-transitional] [--no-frameset] > table.html
173	mkclstbl.pl --help
174
175	=head1 DESCRIPTION
176
177	This script generates an HTML table that describes what element type belongs
178	what element class(es) in versions of HTML.
179
180	=head1 OPTIONS
181
182	This script has four arguments:
183
184	=over 4
185
186	=item --help
187
188	Show help message.
189
190	=item --no-frameset
191
192	Omit some columns that describes Frameset DTDs.
193
194	=item --no-strict
195
196	Omit some columns that describes Strict DTDs, ISO-HTML, XHTML 1.1 or
197	XHTML m12n Abstract Modules.
198
199	=item --no-transitional
200
201	Omit some columns that describes Transitional DTDs.
202
203	=back
204
205	=head1 SEE ALSO
206
207	HTML Specifications and DTDs.
208
209	<http://suika.fam.cx/www/2004/html/>.
210
211	=head1 LICENSE
212
213	Copyright 2004 Wakaba <w@suika.fam.cx>
214
215	This program is free software; you can redistribute it and/or
216	modify it under the same terms as Perl itself.
217
218	=cut
219
220	# $Date: 2004/07/03 06:24:06 $