HTML-Laundry
view release on metacpan or search on metacpan
lib/HTML/Laundry.pm view on Meta::CPAN
# Blow disinfectant in her eyes"<br />
# -- X-Ray Spex, <i>Germ-Free Adolescents</i></p>
=head1 DESCRIPTION
HTML::Laundry is an L<HTML::Parser|HTML::Parser>-based HTML normalizer,
meant for small pieces of HTML, such as user comments, Atom feed entries,
and the like, rather than full pages. Laundry takes these and returns clean,
sanitary, UTF-8-based XHTML. The parser's behavior may be changed with
callbacks, and the whitelist of acceptable elements and attributes may be
updated on the fly.
A snippet is cleaned several ways:
=over 4
=item * Normalized, using HTML::Parser: attributes and elements will be
lowercased, empty elements such as <img /> and <br /> will be forced into
the empty tag syntax if needed, and unknown attributes and elements will be
stripped.
=item * Sanitized, using an extensible whitelist of valid attributes and
elements based on Mark Pilgrim and Aaron Swartz's work on C<sanitize.py>: tags
and attributes which are known to be possible attack vectors are removed.
=item * Tidied, using L<HTML::Tidy|HTML::Tidy> or L<HTML::Tidy::libXML|HTML::Tidy::libXML>
(as available): unclosed tags will be closed and the output generally
neatened; future version may also use tidying to deal with character encoding
issues.
=item * Optionally rebased, to turn relative URLs in attributes into
absolute ones.
=back
HTML::Laundry provides mechanisms to extend the list of known allowed
(and disallowed) tags, along with callback methods to allow scripts using
HTML::Laundry to extend the behavior in various ways. Future versions
may provide additional options for altering the rules used to clean
snippets.
Out of the box, HTML::Laundry does not currently know about the <head> tag
and its children. For santizing full HTML pages, consider using L<HTML::Scrubber|HTML::Scrubber>
or L<HTML::Defang|HTML::Defang>.
=cut
require HTML::Laundry::Rules;
require HTML::Laundry::Rules::Default;
require HTML::Parser;
use HTML::Entities qw(encode_entities encode_entities_numeric);
use URI;
use URI::Escape qw(uri_unescape uri_escape uri_escape_utf8);
use URI::Split qw();
use Scalar::Util 'blessed';
my @fragments;
my $unacceptable_count;
my $local_unacceptable_count;
my $cdata_dirty;
my $in_cdata;
my $tag_leading_whitespace = qr/
(?<=<) # Left bracket followed by
\s* # any amount of whitespace
(\/?) # optionally with a forward slash
\s* # and then more whitespace
/x;
=head1 FUNCTIONS
=head2 new
Create an HTML::Laundry object.
my $l = HTML::Laundry->new();
Takes an optional anonymous hash of arguments:
=over 4
=item * base_url
This turns relative URIs, as in C<<img src="surly_otter.png">>, into
absolute URIs, as for use in feed parsing.
my $l = HTML::Laundry->new({ base_uri => 'http://example.com/foo/' });
=item * notidy
Disable use of HTML::Tidy or HTML::Tidy::libXML, even if
they are available on your system.
my $l = HTML::Laundry->new({ notidy => 1 });
=back
=cut
sub new {
my $self = {};
my $class = shift;
my $args = shift;
if ( blessed $args ) {
if ( $args->isa('HTML::Laundry::Rules') ) {
$args = { rules => $args };
}
else {
$args = {};
}
}
elsif ( ref $args ne 'HASH' ) {
my $rules;
{
local $@;
eval {
$args->isa('HTML::Laundry::Rules')
and $rules = $args->new;
};
}
if ($rules) {
$args = { rules => $args };
}
else {
$args = {};
}
}
$self->{tidy} = undef;
$self->{tidy_added_inline} = {};
$self->{tidy_added_empty} = {};
$self->{base_uri} = q{};
bless $self, $class;
$self->clear_callback('start_tag');
$self->clear_callback('end_tag');
$self->clear_callback('uri');
$self->clear_callback('text');
$self->clear_callback('output');
$self->{parser} = HTML::Parser->new(
api_version => 3,
utf8_mode => 1,
start_h => [ sub { $self->_tag_start_handler(@_) }, 'tagname,attr' ],
end_h => [ sub { $self->_tag_end_handler(@_) }, 'tagname,attr' ],
text_h => [ sub { $self->_text_handler(@_) }, 'dtext,is_cdata' ],
empty_element_tags => 1,
marked_sections => 1,
);
$self->{cdata_parser} = HTML::Parser->new(
api_version => 3,
utf8_mode => 1,
start_h => [ sub { $self->_tag_start_handler(@_) }, 'tagname,attr' ],
end_h => [ sub { $self->_tag_end_handler(@_) }, 'tagname,attr' ],
text_h => [ sub { $self->_text_handler(@_) }, 'dtext' ],
empty_element_tags => 1,
unbroken_text => 1,
marked_sections => 0,
);
$self->initialize($args);
if ( !$args->{notidy} ) {
$self->_generate_tidy;
}
return $self;
}
=head2 initialize
Instantiates the Laundry object properties based on an
HTML::Laundry::Rules module.
=cut
sub initialize {
my ( $self, $args ) = @_;
# Set defaults
$self->{tidy_added_tags} = undef;
$self->{tidy_empty_tags} = undef;
$self->{trim_trailing_whitespace} = 1;
$self->{trim_tag_whitespace} = 0;
$self->{base_uri} = URI->new( $args->{base_uri} )
if $args->{base_uri};
my $rules = $args->{rules};
$rules ||= HTML::Laundry::Rules::Default->new();
$self->{ruleset} = $rules;
# Initialize based on ruleset
$self->{acceptable_a} = $rules->acceptable_a();
$self->{acceptable_e} = $rules->acceptable_e();
$self->{empty_e} = $rules->empty_e();
$self->{unacceptable_e} = $rules->unacceptable_e();
$self->{uri_list} = $rules->uri_list();
$self->{allowed_schemes} = $rules->allowed_schemes();
$rules->finalize_initialization($self);
return;
}
=head2 add_callback
Adds a callback of type "start_tag", "end_tag", "text", "uri", or "output" to
the appropriate internal array.
$l->add_callback('start_tag', sub {
my ($laundry, $tagref, $attrhashref) = @_;
# Now, perform actions and return
});
lib/HTML/Laundry.pm view on Meta::CPAN
=cut
sub add_callback {
my ( $self, $action, $ref ) = @_;
return if ( ref($ref) ne 'CODE' );
if ($action eq q{start_tag}) {
push @{ $self->{start_tag_callback} }, $ref;
} elsif ($action eq q{end_tag}) {
push @{ $self->{end_tag_callback} }, $ref;
} elsif ($action eq q{text}) {
push @{ $self->{text_callback} }, $ref;
} elsif ($action eq q{uri}) {
push @{ $self->{uri_callback} }, $ref;
} elsif ($action eq q{output}) {
push @{ $self->{output_callback} }, $ref;
}
return;
}
=head2 clear_callback
Removes all callbacks of given type.
$l->clear_callback('start_tag');
=cut
sub clear_callback {
my ( $self, $action ) = @_;
if ($action eq q{start_tag}) {
$self->{start_tag_callback} = [ sub { 1; } ];
} elsif ($action eq q{end_tag}) {
$self->{end_tag_callback} = [ sub { 1; } ];
} elsif ($action eq q{text}) {
$self->{text_callback} = [ sub { 1; } ];
} elsif ($action eq q{uri}) {
$self->{uri_callback} = [ sub { 1; } ];
} elsif ($action eq q{output}) {
$self->{output_callback} = [ sub { 1; } ];
}
return;
}
=head2 clean
Cleans a snippet of HTML, using the ruleset and object creation options given
to the Laundry object. The snippet should be passed as a scalar.
$output1 = $l->clean( '<p>The X-rays were penetrating' );
$output2 = $l->clean( $snippet );
=cut
sub clean {
my ( $self, $chunk, $args ) = @_;
$self->_reset_state();
if ( $self->{trim_tag_whitespace} ) {
$chunk =~ s/$tag_leading_whitespace/$1/gs;
}
my $p = $self->{parser};
my $cp = $self->{cdata_parser};
$p->parse($chunk);
if ( !$in_cdata && !$unacceptable_count ) {
$p->eof();
}
if ( $in_cdata && !$local_unacceptable_count ) {
$cp->eof();
}
my $output = $self->gen_output;
$cp->eof(); # Clear buffer if we haven't already
if ($cdata_dirty) { # Overkill to get out of CDATA parser state
$self->{parser} = HTML::Parser->new(
api_version => 3,
start_h =>
[ sub { $self->_tag_start_handler(@_) }, 'tagname,attr' ],
end_h => [ sub { $self->_tag_end_handler(@_) }, 'tagname,attr' ],
text_h => [ sub { $self->_text_handler(@_) }, 'dtext,is_cdata' ],
empty_element_tags => 1,
marked_sections => 1,
);
}
else {
$p->eof(); # Clear buffer if we haven't already
}
return $output;
}
=head2 base_uri
Used to get or set the base_uri property, used in URI rebasing.
my $base_uri = $l->base_uri; # returns current base_uri
$l->base_uri(q{http://example.com}); # return 'http://example.com'
$l->base_uri(''); # unsets base_uri
=cut
sub base_uri {
my ( $self, $new_base ) = @_;
if ( defined $new_base and !ref $new_base ) {
$self->{base_uri} = $new_base;
}
return $self->{base_uri};
}
sub _run_callbacks {
my $self = shift;
my $action = shift;
return unless $action;
my $type = $action . q{_callback};
for my $callback ( @{ $self->{$type} } ) {
my $result = $callback->( $self, @_ );
return unless $result;
}
return 1;
}
=head2 gen_output
Used to generate the final, XHTML output from the internal stack of text and
tag tokens. Generally meant to be used internally, but potentially useful for
callbacks that require a snapshot of what the output would look like
before the cleaning process is complete.
my $xhtml = $l->gen_output;
=cut
sub gen_output {
my $self = shift;
if ( !$self->_run_callbacks( q{output}, \@fragments ) ) {
return q{};
}
my $output = join '', @fragments;
if ( $self->{tidy} ) {
if ( $self->{tidy_engine} eq q{HTML::Tidy} ) {
$output = $self->{tidy}->clean($output);
lib/HTML/Laundry.pm view on Meta::CPAN
}
return 1;
}
sub _generate_tidy {
my $self = shift;
my $param = shift;
$self->_generate_html_tidy;
if ( !$self->{tidy} ) {
$self->_generate_html_tidy_libxml;
}
return;
}
sub _generate_html_tidy_libxml {
my $self = shift;
{
local $@;
eval {
require HTML::Tidy::libXML;
$self->{tidy} = HTML::Tidy::libXML->new();
$self->{tidy_head} = q{<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 1.0 Transitional//EN"
"http://www.w3.org/TR/ html1/DTD/ html1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xmlns="http://www.w3.org/1999/xhtml"><body>};
$self->{tidy_foot} = q{</body></html>
};
$self->{tidy_engine} = q{HTML::Tidy::libXML};
1;
};
}
}
sub _generate_html_tidy {
my $self = shift;
{
local $@;
eval {
require HTML::Tidy;
$self->{tidy_ruleset} = $self->{ruleset}->tidy_ruleset;
if ( keys %{ $self->{tidy_added_inline} } ) {
$self->{tidy_ruleset}->{new_inline_tags}
= join( q{,}, keys %{ $self->{tidy_added_inline} } );
}
if ( keys %{ $self->{tidy_added_empty} } ) {
$self->{tidy_ruleset}->{new_empty_tags}
= join( q{,}, keys %{ $self->{tidy_added_empty} } );
}
$self->{tidy} = HTML::Tidy->new( $self->{tidy_ruleset} );
$self->{tidy_engine} = q{HTML::Tidy};
1;
};
}
}
sub _reset_state {
my ($self) = @_;
@fragments = ();
$unacceptable_count = 0;
$local_unacceptable_count = 0;
$in_cdata = 0;
$cdata_dirty = 0;
return;
}
sub _tag_start_handler {
my ( $self, $tagname, $attr ) = @_;
if ( !$self->_run_callbacks( q{start_tag}, \$tagname, $attr ) ) {
return;
}
if ( !$in_cdata ) {
$cdata_dirty = 0;
}
my @attributes;
foreach my $k ( keys %{$attr} ) {
if ( $self->{acceptable_a}->{$k} ) {
if ( grep {/^$k$/} @{ $self->{uri_list}->{$tagname} } ) {
$self->_uri_handler( $tagname, \$k, \$attr->{$k},
$self->{base_uri} );
}
# Allow uri handler to suppress insertion
if ($k) {
push @attributes, $k . q{="} . $attr->{$k} . q{"};
}
}
}
my $attributes = join q{ }, @attributes;
if ( $self->{acceptable_e}->{$tagname} ) {
if ( $self->{empty_e}->{$tagname} ) {
if ($attributes) {
$attributes = $attributes . q{ };
}
push @fragments, "<$tagname $attributes/>";
}
else {
if ($attributes) {
$attributes = q{ } . $attributes;
}
push @fragments, "<$tagname$attributes>";
}
}
else {
if ( $self->{unacceptable_e}->{$tagname} ) {
if ($in_cdata) {
$local_unacceptable_count += 1;
}
else {
$unacceptable_count += 1;
}
}
}
return;
}
sub _tag_end_handler {
my ( $self, $tagname ) = @_;
if ( !$self->_run_callbacks( q{end_tag}, \$tagname ) ) {
return;
}
if ( !$in_cdata ) {
$cdata_dirty = 0;
}
if ( $self->{acceptable_e}->{$tagname} ) {
if ( !$self->{empty_e}->{$tagname} ) {
push @fragments, "</$tagname>";
}
}
else {
if ( $self->{unacceptable_e}->{$tagname} ) {
if ($in_cdata) {
$local_unacceptable_count -= 1;
$local_unacceptable_count = 0
if ( $local_unacceptable_count < 0 );
}
else {
$unacceptable_count -= 1;
$unacceptable_count = 0 if ( $unacceptable_count < 0 );
}
}
}
return;
}
sub _text_handler {
my ( $self, $text, $is_cdata ) = @_;
if ( $in_cdata && $local_unacceptable_count ) {
return;
}
if ($unacceptable_count) {
return;
}
if ($is_cdata) {
my $cp = $self->{cdata_parser};
$in_cdata = 1;
$cp->parse($text);
if ( !$local_unacceptable_count ) {
$cp->eof();
}
$cdata_dirty = 1;
$in_cdata = 0;
return;
}
else {
if ( !$self->_run_callbacks( q{text}, \$text, $is_cdata ) ) {
return q{};
}
$text = encode_entities( $text, '<>&"' );
$cdata_dirty = 0;
}
push @fragments, $text;
return;
}
sub _uri_handler {
my ( $self, $tagname, $attr_ref, $value_ref, $base ) = @_;
my ( $attr, $value ) = ( ${$attr_ref}, ${$value_ref} );
$value =~ s/[`\x00-\x1f\x7f]+//g;
$value =~ s/\ufffd//g;
my $uri = URI->new($value);
$uri = $uri->canonical;
if ( !$self->_run_callbacks( q{uri}, $tagname, $attr, \$uri ) ) {
${$attr_ref} = q{};
return undef;
}
if ( $self->{allowed_schemes} and $uri->scheme ) {
unless ( $self->{allowed_schemes}->{ $uri->scheme } ) {
${$attr_ref} = q{};
return undef;
}
}
if ( $self->{base_uri} ) {
$uri = URI->new_abs( $uri->as_string, $self->{base_uri} );
}
if ( $uri->scheme ) { # Not a local URI
my $host;
{
local $@;
eval { $host = $uri->host; };
}
if ($host) {
# We may need to manually unescape domain names
# to deal with issues like tinyarro.ws
my $utf8_host = $self->_decode_utf8($host);
utf8::upgrade($utf8_host);
if ( $uri->host ne $utf8_host ) {
# TODO: Optionally use Punycode in this case
if ( $uri->port and $uri->port == $uri->default_port ) {
$uri->port(undef);
}
my $escaped_host = $self->_encode_utf8( $uri->host );
my $uri_str = $uri->canonical->as_string;
$uri_str =~ s/$escaped_host/$utf8_host/;
utf8::upgrade($uri_str);
${$value_ref} = $uri_str;
return;
}
}
}
${$value_ref} = $uri->canonical->as_string;
return;
}
sub _decode_utf8 {
my $self = shift;
my $orig = my $str = shift;
( run in 0.732 second using v1.01-cache-2.11-cpan-600a1bdf6e4 )