File Coverage

lib/HTML/Normalize.pm

Criterion	Covered	Total	%
statement	230	243	94.6
branch	97	120	80.8
condition	31	45	68.8
subroutine	26	26	100.0
pod	2	2	100.0
total	386	436	88.5

package HTML::Normalize;

use strict;
use warnings;
use HTML::Entities;
use HTML::TreeBuilder;
use HTML::Tagset;
use Carp;

BEGIN {
    use Exporter ();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION     = '1.0003';
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    @EXPORT_OK   = qw();
    %EXPORT_TAGS = ();
}

=head1 NAME

HTML::Normalize - HTML light weight cleanup

=head1 VERSION

Version 1.0003

=head1 SYNOPSIS

    my $norm = HTML::Normalize->new ();
    my $cleanHtml = $norm->cleanup (-html => $dirtyHtml);

=head1 DESCRIPTION

HTML::Normalize uses HTML::TreeBuilder to parse an HTML string then processes
the resultant tree to clean up various structural issues in the original HTML.
The result is then rendered using HTML::Element's as_HTML member.

Key structural clean ups fix tag soup (C<< foo >> becomes C<<
foo >>) and inline/block element nesting (C<<
foo >> becomes C<< foo >>). C<<  >>
tags at the start or end of a link element are migrated out of the element.

Note that HTML::Normalize's approach to cleaning up tag soup is different than
that used by HTML::Tidy. HTML::Tidy tends to enforce nested and swaps end tags
to achieve that. HTML::Normalize inserts extra tags to allow correctly taged
overlapped markup.

HTML::Normalize can also remove attributes set to default values and empty
elements. For example a C<<  >>
element would become and C<<  >> and C<<
face="Verdana" size="1"> >> would be removed if Verdana size 1 is set as the
default font.

=head1 Methods

C creates an HTML::Normalize instance and performs parameter validation.

C Validates any further parameters and check parameter consistency then
parses the HTML to generate the internal representation. It then edits the
internal representation and renders the result back into HTML.

Note that I may be called multiple times with different HTML strings to
process.

Generally errors are handled by carping and may be detected in both I and
I.

=cut

=head2 new

Create a new C instance.

    my $norm = HTML::Normalize->new ();

=over 4

=item I<-compact>: optional

Setting C<< -compact => 1 >> suppresses generation of 'optional' close tags.
This reduces the sizeof the output slightly at the expense of breaking any hope
of XHTML compliance.

=item I<-default>: optional - multiple

Define a default attribute for an element. Default attributes are removed if the
attribute value has not been overridden in a parent node. For element such as
'font' this may result in the element being removed if no attributes remain.

C<-default> takes a string of the form 'tag attribute=value' as an argument.
For example:

    -default => 'font face="Verdana"'

would specify that the face "Verdana" is the default face attribute for font
elements.

I may be a constant or a regular expression. A regular expression
matches:

    /(~|qr)\s*(.).*\1\s*$/

except that the paired delimiters [], {}, () and <> are also accepted as pattern
delimiters.

Literal match values should not encode entities, but remember that quotes around
attribute values are optional for some values so the outer pair of quote
characters will be removed if present. The match value extends to the end of the
line and is not bounded by quote qharacters (except as noted earlier) so no
quoting of "special" characters is required - there are no special characters.

Multiple default attributes may be provided but only one default value is
allowed for any one tag/attribute pair.

Default values are case sensitive. However you can use the regular expression
form to overcome this limitation.

=item I<-distribute>: optional - default true

Distribute inline elements over children if the children are block level
elements. For example:

    foobar

becomes:

    foobar

This action is only taken if all the child elements are block level elements.

=item I<-expelbr>: optional - default true

If C<-expelbr> is true (the default) break elements at the edges of link
elements are expelled from the link element. Thus:

    link text

becomes

    link text

=item I<-html>: required

the HTML string to clean.

=item I<-indent>: optional - default '   '

String used to indent formatted output. Ignored if I<-unformatted> is true.

=item I<-keepimplicit>: optional

as_HTML adds various HTML required sections such as head and body elements. By
default HTML::Normalize removes these elements so that it is suitable for
processing HTML fragments. Set C<-keepimplicit => 1> to render the implicit
elements.

Note that if this option is true, the extra nodes will be generated regardless
of their presence in the original HTML.

=item I<-maxlinelen>: optional - default 80

Notional maximum line length if I<-selfrender> is true. The line length may be
exceeded if no suitable break position is found. Note that the current indent is
included in the line length.

=item I<-selfrender>: optional

Use the experimental HTML::Normalize code to render HTML rather than using
HTML::Element's renderer. This code has not been tested against a wide range of
HTML and may be unreliable. It's advantage is that it produces (in the author's
opinion) prettier output than HTML::Element's as_HTML member.

=item I<-unformatted>: optional

Suppress output formatting. By default as_HTML is called as

    as_HTML (undef, '   ', {})

which wraps and indents elements. Setting C<< -unformatted => 1 >> suppresses
generation of line breaks and indentation reducing the size of the output
slightly.

=back

=cut

my %paramTypes = (

    # 0: optional once
    # 1: required once
    # 2: optional, many allowed
    -compact      => [0, 0],
    -default      => [2, undef],
    -distribute   => [0, 1],
    -expelbr      => [0, 1],
    -html         => [1, undef],
    -indent       => [0, '   '],
    -keepimplicit => [0, 0],
    -maxlinelen   => [0, 80],
    -selfrender   => [0, 0],
    -unformatted  => [0, 0],
);
my $regex = '
    (?:~|qr)\s*
    (?:
         (.).*\4  # regex quote char delimited
        |<.*>     # regex <> delimited
        |{.*}     # regex {} delimited
        |\[.*\]   # regex [] delimited
        |\(.*\)   # regex () delimited
    )i?               # Regex match
    ';

sub new {
    my ($self, @params) = @_;

    unless (ref $self) {
        $self = bless {}, $self;
        $self->{both}     = qr/^(del|ins)$/i;
        $self->{inline}   = qr/^(b|i|s|font|span)$/i;
        $self->{block}    = qr/^(p|table|div)$/i;
        $self->{needattr} = qr/^(font|span)$/i;
        $self->{selfclose} = qr/^(br)$/i;
    }

    $self->_validateParams (
        \@params,
        [
            qw(-compact -default -distribute -expelbr -keepimplicit -unformatted )
        ],
        []
    );

    # Add 'div' to the closure barriers list to avoid changing:
    #   foo
    # into:
    #   foo
    my $bar = \@HTML::Tagset::p_closure_barriers;
    push @$bar, 'div' unless grep { $_ eq 'div' } @$bar;

    return $self;
}

sub DESTROY {
    my $self = shift;
    $self->{root}->delete if $self->{root};
}

sub _validateParams {
    my ($self, $params, $okParams, $requiredParams) = @_;

    $params         ||= [];
    $okParams       ||= [];
    $requiredParams ||= [];

    # Validate parameters
    while (@$params) {
        my ($key, $value) = splice @$params, 0, 2;

        $key = lc $key;
        croak "$key is not a valid parameter name" if !exists $paramTypes{$key};
        croak "$key parameter may only be used once"
          if $paramTypes{$key}[0] < 2 && exists $self->{$key};

        if ($paramTypes{$key}[0] < 2) {
            $self->{$key} = $value;
            next;
        }

        push @{$self->{$key}}, $value;
    }

    # Ensure we got required parameters
    for my $key (@$requiredParams) {
        croak "Invalid parameter name: $key" unless exists $paramTypes{$key};
        $self->{$key} = $paramTypes{$key}[1] unless exists $self->{$key};
        next if $paramTypes{$key}[0] != 1 or exists $self->{$key};
        croak "The $key parameter is missing. It is required.";
    }
}

=head2 cleanup

C takes no parameters and returns the cleaned up version of the HTML.

    my $cleanHtml = $norm->cleanup ();

=cut

sub cleanup {
    my ($self, @params) = @_;

    $self->_validateParams (\@params, [keys %paramTypes], ['-html']);

    # Check we got all required parameters and set any defaults
    for my $param (keys %paramTypes) {
        next if exists $self->{$param};
        next if $paramTypes{$param}[0] > 1;

        croak "A $param parameter must be provided. None was."
          if $paramTypes{$param}[0] == 1;

        # Set missing param to default
        $self->{$param} = $paramTypes{$param}[1];
    }

    # Unpack any -default parameters
    for my $default (@{$self->{-default}}) {
        my ($tag, $attrib, $value) =
          $default =~ /
            (\w+)\s+                    # Tag
            (\w+)\s*                    # Attribute
            (?:=\s*(?=[\w'"])|=(?=~))
            (   '[^']*'             # Single quoted
               |"[^"]*"             # Double quoted
               |\w+                 # Unquoted
               |$regex              # regex match
            )\s*                        # Value
            $/x;

        croak "Badly formed default attribute string: $default"
          unless defined $value;
        $_ = lc for $tag, $attrib;

        croak "Conflicting defaults given:\n"
          . "   $tag $attrib=$self->{defaults}{$tag}{$attrib}\n"
          . "and\n   $tag $attrib=$value\n"
          if exists $self->{defaults}{$tag}{$attrib}
              and $self->{defaults}{$tag}{$attrib} ne $value;

        if ($value =~ /^()()()$regex$/x) {
            # Compile regex
            $value =~ s/^~\s*/qr/;
            $value = eval $value;
        } else {
            # Strip quotes if present from match value
            $value =~ s/^(['"])(.*)\1$/$2/;
    }

        $self->{defaults}{$tag}{$attrib} = $value;
    }

    $self->{root} = HTML::TreeBuilder->new;
    $self->{root}->parse_content ($self->{-html});
    $self->{root}->elementify    ();

    1 while $self->_cleanedupElt ($self->{root});

    my $str = '';

    if ($self->{-selfrender}) {
        $self->{line} = '';
        $str = $self->_render ($self->{root}, '');
    } else {
        my @renderOptions = (undef, '   ', {});

        $renderOptions[1] = undef if $self->{-unformatted};
        $renderOptions[2] = undef if $self->{-compact};

        my $elt = $self->{root};

        if (! $self->{-keepimplicit}) {
            ($elt) = grep {$_->{_tag} eq 'body'} $self->{root}->descendents ();
        }

        $str .= ref $_ ? $_->as_HTML (@renderOptions) : $_
            for @{$elt->{_content}};
    }

    return $str;
}

sub _cleanedupElt {
    my ($self, $parent) = @_;

    return 0 unless ref $parent && ref $parent->{_content};

    my $rescan = 1;    # Set true to rescan the child element list
    my $touched;

    while ($rescan) {
        $rescan = 0;    # Assume another scan not required after current scan
        ++$touched;

        for my $elt ($parent->content_list ()) {
            next unless ref $elt;

            ++$rescan, last if $self->_cleanedupElt ($elt);
            next if exists $elt->{_implicit};

            ++$rescan, last if $self->_removedDefaults     ($elt);
            ++$rescan, last if $self->_distributedElements ($elt);
            ++$rescan, last if $self->_normalizedElements  ($elt);
            ++$rescan, last if $self->_expeledBr           ($elt);
            ++$rescan, last if $self->_removedEmpty        ($elt);
        }
    }

    return $touched > 1;
}

sub _distributedElements {
    my ($self, $elt) = @_;

    return 0 unless $self->{-distribute};
    return 0
      unless $elt->{_tag} =~ $self->{inline}
          && $elt->{_tag} =~ $self->{needattr};

    my @elts = $elt->content_list ();
    my $blockElts = grep {ref $_ && $_->{_tag} =~ $self->{block}} @elts;

    # Done unless all child elements are block level elements
    return 0 unless @elts && @elts == $blockElts;

    # Distribute inline element over and block elements
    $elt->replace_with_content ();

    for my $block (@elts) {
        my @nested = $block->detach_content ();
        my $clone  = $elt->clone            ();

        $block->push_content ($clone);
        $clone->push_content (@nested);
    }

    $elt->delete ();
    return 1;
}

sub _normalizedElements {
    my ($self, $elt) = @_;

    return 0 unless $elt->{_tag} =~ $self->{inline};

    my @elts = $elt->content_list ();

    # Ok unless element contains single block level child
    return 0
      unless @elts == 1
          && ref $elts[0]
          && $elts[0]->{_tag} =~ $self->{block};

    # Invert order of inline and block elements
    my @nested = $elts[0]->detach_content ();

    $elt->replace_with ($elts[0]);
    $elts[0]->push_content ($elt);
    $elt->push_content (@nested);
    $elt = $elts[0];

    $_->replace_with_content ()->delete ()
      for grep {$self->_removedEmpty ($_)} @elts;

    return 1;
}

sub _expeledBr {
    my ($self, $elt) = @_;

    return 0 unless $elt->{_tag} eq 'a' && $self->{-expelbr};
    return 0 unless exists $elt->{_content};

    my $adjusted;
    for my $index (0, -1) {
        my $br = $elt->{_content}[$index];

        next unless ref $br && $br->{_tag} eq 'br';
        $index == 0
          ? $br->detach ()->preinsert ($br)
          : $br->detach ()->postinsert ($br);
        ++$adjusted;
    }

    return $adjusted;
}

sub _removedDefaults {
    my ($self, $elt) = @_;

    return 0 unless exists $self->{defaults}{$elt->{_tag}};

    my $delAttribs = $self->{defaults}{$elt->{_tag}};

    for my $attrib (keys %$delAttribs) {
        next unless exists $elt->{$attrib};

        my $value = $delAttribs->{$attrib};
        my @parentAttribs;
        my @criteria = (_tag  => $elt->{_tag});

        if ('Regexp' eq ref $value) {
            next unless $elt->{$attrib} =~ $value;
            push @criteria, sub {
                my $attr = $_[0]->attr("$attrib");
                return 0 unless defined $attr;
                return $attr !~ $value;
                };
        } else {
            my $value = $delAttribs->{$attrib};

            next unless $elt->{$attrib} eq $value;
            push @criteria, ($attrib => qr/^(?!\Q$value\E)/i);
        }

        @parentAttribs = $elt->look_up (@criteria);

        # Don't delete attribute required to restore default
        next if @parentAttribs;
        delete $elt->{$attrib};
    }

    return $self->_removedEmpty ($elt);
}

sub _removedEmpty {
    my ($self, $elt) = @_;

    return 0 if grep {!/^_/} $elt->all_attr_names ();
    return 0 unless $elt->{_tag} =~ $self->{needattr};

    # Remove redundant element - no attributes left
    $elt->replace_with ($elt->detach_content ());
    $elt->delete ();
    return 1;
}

sub _render {
    my ($self, $elt, $indent) = @_;

    return ''
      unless $self->{-keepimplicit} || !$elt->{_implicit} || $elt->{_content};

    my $str = '';

    if (! $self->{-keepimplicit} && $elt->{_implicit}) {
        return $self->_renderContents ($elt, $indent);

    } elsif ($elt->{_tag} =~ $self->{selfclose}) {
        $str .= $self->_append ("<$elt->{_tag} />", $indent);

    } elsif ($HTML::Tagset::isPhraseMarkup{$elt->{_tag}}) {
        $str .= $self->_append ("<$elt->{_tag}", $indent);
        $str .= $self->_renderAttrs ($elt, $indent);
        $str .= $self->_renderContents ($elt, $indent);
        $str .= $self->_append ("{_tag}>",$indent);

    } else {
        my $indented = "$indent$self->{-indent}";

        $str = $self->_flushLine ($indent);
        $self->{line} .= "<$elt->{_tag}";
        $self->{ishead} = 1;
        $str .= $self->_renderAttrs ($elt, $indented);
        $str .= $self->_renderContents ($elt, $indented);
        $str .= $self->_append ("{_tag}>", $indented);
        $str .= $self->_flushLine ($indented);
    }

    return $str;
}

sub _append {
    my ($self, $tail, $indent) = @_;

    if ((length ($self->{line}) + length ($tail) + length ($indent)) > $self->{-maxlinelen}) {
        my $str = $self->_flushLine ($indent);

        $self->{line} = $tail;
        return $str;
    } else {
        $self->{line} .= $tail;
        return '';
    }
}

sub _flushLine {
    my ($self, $indent) = @_;

    return '' unless length $self->{line};

    my $str;

    if ($self->{-unformatted}) {
        $str = $self->{line};

    } else {
        if ($self->{ishead}) {
            substr ($indent, -length $self->{-indent}) = '';
            $self->{isHead} = undef;
        }

        $str = "$indent$self->{line}\n";
    }

    $self->{line} = '';
    return $str;
}

sub _renderAttrs {
    my ($self, $elt, $indent) = @_;
    my $str = '';
    my @attrs = grep {! /^_/} keys %$elt;

    $str .= $self->_append (
        qq( $_=") . encode_entities ($elt->{$_}) . qq("),
        $indent
        )
        for sort @attrs;
    $self->{line} .= '>';
    return $str;
}

sub _renderContents {
    my ($self, $elt, $indent) = @_;
    my $str = '';

    for my $subElt (@{$elt->{_content}}) {
        if (! ref $subElt) {
            $str .= $self->_renderText ($subElt, $indent);
        } else {
            $str .= $self->_render ($subElt, $indent);
        }
    }

    return $str;
}


sub _renderText {
    my ($self, $elt, $indent) = @_;
    my $str = $self->{line} . encode_entities ($elt);

    if ($self->{-unformatted}) {
        $self->{line} = '';

    } else {
        my $maxLen = $self->{-maxlinelen} - length $indent;

        $str =~ s/(.{,$maxLen})\s+/$indent$1\n/g;
        ($str, $self->{line}) = $str =~ /(.*\n)?(.*)/;
        $str = '' unless defined $str;
        $self->{line} = '' unless defined $self->{line};
    }

    return $str;
}


1;

=head1 BUGS

=head3 p/div/p parsing issue

HTML::TreeBuilder 3.23 and earlier misparses:

    foo

as:

     foo

A work around in HTML::Normalize turns that into

    foo

which is probably still incorrect - div elements should not nest within p
elements. A better fix for the problem requires HTML::TreeBuilder to be fixed.

=head3 Bug reports and feature requests

Please report any other bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

This module is supported by the author through CPAN. The following links may be
of assistance:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

This module was inspired by Bart Lateur's PerlMonks node 'Cleaning up HTML'
(L) and is a collaboration between Bart
and the author.

=head1 AUTHOR

    Peter Jaquiery
    CPAN ID: GRANDPA
    [e-mail]

=head1 COPYRIGHT & LICENSE

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

The full text of the license can be found in the
LICENSE file included with this module.

=cut