Fixes some common XHTML validation errors, to make a web page pass the W3C markup validator. Does this still work? I have no idea, I never build web pages by hand anymore.
#!/usr/bin/perl -cw
#
# Clean up a few common xhtml validation errors
#
# Arguments: provide any number of filenames on the command line
# Each file will be cleaned, with original saved as file.bak[.num]
{
# Parser class to replace font tags with suitable values
package CleanupParser;
use base 'HTML::Parser';
# presentational attributes to remove from all tags
# exception: <img> gets to keep width and height
my @STRIP_ATTR = ('border', 'cellpadding', 'cellspacing',
'width', 'height', 'align', 'valign', 'hspace', 'vspace',
'target', 'onmouse', 'onmouseover', 'onclick', 'nowrap'
);
# presentation tags to remove
my @STRIP_TAGS = (
'center',
);
# Font substitution table
my %fontsub = (
#font size => replacement tag
'1' => '',
'2' => '', # 2 is normal size, just delete
'3' => 'h4',
'4' => 'h3',
'5' => 'h2',
'6' => 'h1',
'+1' => 'h3',
'+2' => 'h2',
'+3' => 'h1',
'+4' => 'h1',
'+5' => 'h1',
'+6' => 'h1',
'-1' => '',
'-2' => '',
'-3' => '',
'-4' => '',
'-5' => '',
'-6' => '',
);
# Store font closing tags on this stack
my @fontstack = ();
# Store processed document in this string
my $result = '';
# Form the correct closing tag from an open tag w/ attributes
sub close_tag {
my ($tag) = @_;
return '/' . (split (/\s+/, $tag))[0];
}
# Create a text representation of a tag
# Uses attrseq for attributes; values in attr but not attrseq won't
# be copied. This allows stripping attributes while still saving
# their value for later processing.
sub make_text {
my ($self, $tagname, $attr, $attrseq) = @_;
my $text = "<$tagname";
# The / on /> closing marker for strict xhtml tags is not an
# attribute but parser catches it as one. We remedy that here.
foreach my $key (grep { $_ ne '/' } @$attrseq) {
my $val = $attr->{$key};
$text .= " $key=\"$val\"";
}
$text .= exists $attr->{'/'} ? ' />' : '>';
#print " $text\n";
}
# Process start tags. First strip any attributes found
# in STRIP_ATTR out of $attrseq (but leave $attr untouched
# so original values still accessible). Next, if a method named
# start_TAG exists, call it. Otherwise, just copy the tag to the
# result.
sub start {
my ($self, $tagname, $attr, $attrseq, $text) = @_;
# strip out presentation attributes
foreach my $key (@STRIP_ATTR) {
if (exists $attr->{$key}) {
# strip from attrseq but leave in attr
@$attrseq = grep { $_ ne $key } @$attrseq;
}
}
$text = $self->make_text ($tagname, $attr, $attrseq);
my $meth = $self->can ("start_" . $tagname);
if ($meth) {
$self->$meth ($attr, $attrseq, $text);
}
elsif (grep { $_ eq $tagname } @STRIP_TAGS) {
return;
}
else {
$result .= $text;
}
}
# start tag function template
sub start_X {
my ($self, $attr, $attrseq, $text) = @_;
}
# Change bold to strong
sub start_b {
my ($self, $attr, $attrseq, $text) = @_;
$result .= '<strong>';
}
sub end_b {
my ($self, $tagname, $text) = @_;
$result .= '</strong>';
}
# Change italics to em
sub start_i {
my ($self, $attr, $attrseq, $text) = @_;
$result .= '<em>';
}
sub end_i {
my ($self, $tagname, $text) = @_;
$result .= '</em>';
}
# Restore height/width attributes to images
sub start_img {
my ($self, $attr, $attrseq, $text) = @_;
if (exists $attr->{'width'}) { push (@$attrseq, 'width'); }
if (exists $attr->{'height'}) { push (@$attrseq, 'height'); }
$text = $self->make_text ('img', $attr, $attrseq);
$result .= $text;
}
# Process <font>
sub start_font {
my ($self, $attr, $attrseq, $text) = @_;
my $size = ($attr->{'size'} or '');
my $replacement = $fontsub{$size};
if ($replacement) {
#print "size = $size, replace with $replacement\n";
push (@fontstack, close_tag ($replacement));
# write replacement tag
$result .= "<$replacement>";
} else {
push (@fontstack, '');
#print "no size attr\n";
}
}
# Process end tags. If a method named end_TAG exists, call it.
# Otherwise, just copy the tag to the result.
sub end {
my ($self, $tagname, $text) = @_;
my $meth = $self->can ("end_" . $tagname);
if ($meth) {
$self->$meth ($text);
}
else {
$result .= $text;
}
}
# end tag function template
sub end_X {
my ($self, $tagname, $text) = @_;
}
# Process </font>
sub end_font {
my ($self, $text) = @_;
my $replacement = pop (@fontstack);
#if ($replacement) { print "<$replacement>"; }
if ($replacement) { $result .= "<$replacement>"; }
}
# Everything else gets spit out verbatim
sub text {
my ($self, $text) = @_;
#print $text;
$result .= $text;
}
# Return the processed document and clear the storage buffer
# Must be called before parsing new doc
sub finish {
my $doc = $result;
$result = '';
return $doc;
}
# # Use same handler as text for these types
# *comment = \&text;
# *declaration = \&text;
# *process = \&text;
}; # end CleanupParser
# ------------- Main --------------------
foreach my $file (@ARGV) {
my $tmpfile = "$file.tmp";
open (OLD, "<$file") or die "open failed ($file): $!";
open (NEW, ">$tmpfile") or die "open failed ($tmpfile): $!";
@lines = <OLD>;
$content = join ('', @lines);
my $parser = CleanupParser->new(
#api_version => 3,
#default_h => [sub { print shift }, 'text'],
default_h => ['text', 'self,text'],
start_h => ['start', 'self,tagname,attr,attrseq,text'],
end_h => ['end', 'self,tagname,text'],
);
#$parser->xml_mode (1);
#$parser->parse_file ($file);
$parser->parse ($content);
$parser->eof;
$content = $parser->finish;
print NEW $content;
close (OLD) or die "close failed ($file): $!";
close (NEW) or die "close failed ($tmpfile): $!";
my $bakfile = "$file.cln.bak";
my $cnt = 0;
while (-e $bakfile) { $bakfile = "$file.$cnt.cln.bak"; $cnt++; }
#warn "WARNING: renaming disabled\n";
rename ($file, $bakfile) or die "move failed ($file -> $bakfile): $!";
rename ($tmpfile, $file) or die "move failed ($tmpfile -> $file): $!";
print "saved $file as $bakfile\n"
}
