File Coverage

blib/lib/HTML/Laundry.pm

Criterion	Covered	Total	%
statement	396	487	81.3
branch	131	160	81.8
condition	11	21	52.3
subroutine	51	53	96.2
pod	18	18	100.0
total	607	739	82.1

########################################################
# Copyright © 2009 Six Apart, Ltd.

package HTML::Laundry;

use strict;
use warnings;

use 5.008;
use version; our $VERSION = 0.0103;

=head1 NAME

HTML::Laundry - Perl module to clean HTML by the piece

=head1 VERSION

Version 0.0103

=head1 SYNOPSIS

    #!/usr/bin/perl -w
    use strict;
    use HTML::Laundry;
    my $laundry = HTML::Laundry->new();
    my $snippet = q{
        "You may get to touch her
        If your gloves are sterilized
        Rinse your mouth with Listerine
        Blow disinfectant in her eyes"
        -- X-Ray Spex, Germ-Free Adolescents
        alert('!!');
    };
    my $germfree = $laundry->clean($snippet);
    # $germfree is now:
    #   "You may get to touch her
    #   If your gloves are sterilized
    #   Rinse your mouth with Listerine
    #   Blow disinfectant in her eyes"
    #   -- X-Ray Spex, Germ-Free Adolescents

=head1 DESCRIPTION

HTML::Laundry is an L-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  and  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: tags
and attributes which are known to be possible attack vectors are removed.

=item * Tidied, using L or L
(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  tag
and its children. For santizing full HTML pages, consider using L
or L.

=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';
use Switch;

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<>, 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
    });

start_tag, end_tag, text, and uri callbacks that return false values will
suppress the return value of the element they are processing; this allows
additional checks to be done (for instance, images can be allowed only from
whitelisted source domains).

=cut

sub add_callback {
    my ( $self, $action, $ref ) = @_;
    return if ( ref($ref) ne 'CODE' );
    switch ($action) {
        case q{start_tag} {
            push @{ $self->{start_tag_callback} }, $ref;
        }
        case q{end_tag} {
            push @{ $self->{end_tag_callback} }, $ref;
        }
        case q{text} {
            push @{ $self->{text_callback} }, $ref;
        }
        case q{uri} {
            push @{ $self->{uri_callback} }, $ref;
        }
        case 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 ) = @_;
    switch ($action) {
        case q{start_tag} {
            $self->{start_tag_callback} = [ sub { 1; } ];
        }
        case q{end_tag} {
            $self->{end_tag_callback} = [ sub { 1; } ];
        }
        case q{text} {
            $self->{text_callback} = [ sub { 1; } ];
        }
        case q{uri} {
            $self->{uri_callback} = [ sub { 1; } ];
        }
        case 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( '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);
            $self->{tidy}->clear_messages;
        }
        elsif ( $self->{tidy_engine} eq q{HTML::Tidy::libXML} ) {
            my $clean
                = $self->{tidy}
                ->clean( $self->{tidy_head} . $output . $self->{tidy_foot},
                'UTF-8', 1 );
            $output = substr( $clean, length $self->{tidy_head} );
            $output = substr( $output, 0, -1 * length $self->{tidy_foot} );
        }
    }
    if ( $self->{trim_trailing_whitespace} ) {
        $output =~ s/\s+$//;
    }
    return $output;
}

=head2 empty_elements

Returns a list of the Laundry object's known empty elements: elements such
as  or  which must not contain any children.

=cut

sub empty_elements {
    my ( $self, $listref ) = @_;
    if ($listref) {
        my @list = @{$listref};
        my %empty = map { ( $_, 1 ) } @list;
        $self->{empty_e} = \%empty;
    }
    return keys %{ $self->{empty_e} };
}

=head2 remove_empty_element

Removes an element (or, if given an array reference, multiple elements) from
the "empty elements" list maintained by the Laundry object.

    $l->remove_empty_element(['img', 'br']); # Let's break XHTML!

This will not affect the acceptable/unacceptable status of the elements.

=cut

sub remove_empty_element {
    my ( $self, $new_e, $args ) = @_;
    my $empty = $self->{empty_e};
    if ( ref($new_e) eq 'ARRAY' ) {
        foreach my $e ( @{$new_e} ) {
            $self->remove_empty_element( $e, $args );
        }
    }
    else {
        delete $empty->{$new_e};
    }
    return 1;
}

=head2 acceptable_elements

Returns a list of the Laundry object's known acceptable elements, which will
not be stripped during the sanitizing process.

=cut

sub acceptable_elements {
    my ( $self, $listref ) = @_;
    if ( ref($listref) eq 'ARRAY' ) {
        my @list = @{$listref};
        my %acceptable = map { ( $_, 1 ) } @list;
        $self->{acceptable_e} = \%acceptable;
    }
    return keys %{ $self->{acceptable_e} };
}

=head2 add_acceptable_element

Adds an element (or, if given an array reference, multiple elements) to the
"acceptable elements" list maintained by the Laundry object. Items added in
this manner will automatically be removed from the "unacceptable elements"
list if they are present.

    $l->add_acceptable_element('style');

Elements which are empty may be flagged as such with an optional argument.
If this flag is set, all elements provided by the call will be added to
the "empty element" list.

    $l->add_acceptable_element(['applet', 'script'], { empty => 1 });

=cut

sub add_acceptable_element {
    my ( $self, $new_e, $args ) = @_;
    my $acceptable   = $self->{acceptable_e};
    my $empty        = $self->{empty_e};
    my $unacceptable = $self->{unacceptable_e};
    if ( ref($new_e) eq 'ARRAY' ) {
        foreach my $e ( @{$new_e} ) {
            $self->add_acceptable_element( $e, $args );
        }
    }
    else {
        $acceptable->{$new_e} = 1;
        if ( $args->{empty} ) {
            $empty->{$new_e} = 1;
            if ( $self->{tidy} ) {
                $self->{tidy_added_inline}->{$new_e} = 1;
                $self->{tidy_added_empty}->{$new_e}  = 1;
                $self->_generate_tidy;
            }
        }
        elsif ( $self->{tidy} ) {
            $self->{tidy_added_inline}->{$new_e} = 1;
            $self->_generate_tidy;
        }
        delete $unacceptable->{$new_e};

    }
    return 1;
}

=head2 remove_acceptable_element

Removes an element (or, if given an array reference, multiple elements) to the
"acceptable elements" list maintained by the Laundry object. These items
(although not their child elements) will now be stripped during parsing.

    $l->remove_acceptable_element(['img', 'h1', 'h2']);
    $l->clean(q{The Day the World Turned Day-Glo});
    # returns 'The Day the World Turned Day-Glo'

=cut

sub remove_acceptable_element {
    my ( $self, $new_e, $args ) = @_;
    my $acceptable = $self->{acceptable_e};
    if ( ref($new_e) eq 'ARRAY' ) {
        foreach my $e ( @{$new_e} ) {
            $self->remove_acceptable_element( $e, $args );
        }
    }
    else {
        delete $acceptable->{$new_e};
    }
    return 1;
}

=head2 unacceptable_elements

Returns a list of the Laundry object's unacceptable elements, which will be
stripped -- B child objects -- during the cleaning process.

=cut

sub unacceptable_elements {
    my ( $self, $listref ) = @_;
    if ( ref($listref) eq 'ARRAY' ) {
        my @list = @{$listref};
        my %unacceptable
            = map { $self->remove_acceptable_element($_); ( $_, 1 ); } @list;
        $self->{unacceptable_e} = \%unacceptable;
    }
    return keys %{ $self->{unacceptable_e} };
}

=head2 add_unacceptable_element

Adds an element (or, if given an array reference, multiple elements) to the
"unacceptable elements" list maintained by the Laundry object.

    $l->add_unacceptable_element(['h1', 'h2']);
    $l->clean(q{The Day the World Turned Day-Glo});
    # returns null string

=cut

sub add_unacceptable_element {
    my ( $self, $new_e, $args ) = @_;
    my $unacceptable = $self->{unacceptable_e};
    if ( ref($new_e) eq 'ARRAY' ) {
        foreach my $e ( @{$new_e} ) {
            $self->add_unacceptable_element( $e, $args );
        }
    }
    else {
        $self->remove_acceptable_element($new_e);
        $unacceptable->{$new_e} = 1;
    }
    return 1;
}

=head2 remove_unacceptable_element

Removes an element (or, if given an array reference, multiple elements) from
the "unacceptable elements" list maintained by the Laundry object. Note that
this does not automatically add the element to the acceptable_element list.

    $l->clean(q{alert('!')});
    # returns null string
    $l->remove_unacceptable_element( q{script} );
    $l->clean(q{alert('!')});
    # returns "alert('!')"

=cut

sub remove_unacceptable_element {
    my ( $self, $new_e, $args ) = @_;
    my $unacceptable = $self->{unacceptable_e};
    if ( ref($new_e) eq 'ARRAY' ) {
        foreach my $a ( @{$new_e} ) {
            $self->remove_unacceptable_element( $a, $args );
        }
    }
    else {
        delete $unacceptable->{$new_e};
    }
    return 1;
}

=head2 acceptable_attributes

Returns a list of the Laundry object's known acceptable attributes, which will
not be stripped during the sanitizing process.

=cut

sub acceptable_attributes {
    my ( $self, $listref ) = @_;
    if ( ref($listref) eq 'ARRAY' ) {
        my @list = @{$listref};
        my %acceptable = map { ( $_, 1 ) } @list;
        $self->{acceptable_a} = \%acceptable;
    }
    return keys %{ $self->{acceptable_a} };
}

=head2 add_acceptable_attribute

Adds an attribute (or, if given an array reference, multiple attributes) to the
"acceptable attributes" list maintained by the Laundry object.

    my $snippet = q{ "My dear Mr. Bennet," said his lady to
        him one day, "have you heard that
        Netherfield Park is let at last?"
    };
    $l->clean( $snippet );
    # returns:
    #   "My dear Mr. Bennet," said his lady to him one day,
    #   "have you heard that Netherfield Park is let at
    #   last?"
    $l->add_acceptable_attribute([austen:id, austen:footnote]);
    $l->clean( $snippet );
    # returns:
    #   "My dear Mr. Bennet," said his lady to him
    #   one day, "have you heard that
    #   Netherfield Park is let at last?"

=cut

sub add_acceptable_attribute {
    my ( $self, $new_a, $args ) = @_;
    my $acceptable = $self->{acceptable_a};
    if ( ref($new_a) eq 'ARRAY' ) {
        foreach my $a ( @{$new_a} ) {
            $self->add_acceptable_attribute( $a, $args );
        }
    }
    else {
        $acceptable->{$new_a} = 1;
    }
    return 1;
}

=head2 remove_acceptable_attribute

Removes an attribute (or, if given an array reference, multiple attributes)
from the "acceptable attributes" list maintained by the Laundry object.

    $l->clean(q{plover});
    # returns 'plover'
    $l->remove_acceptable_element( q{id} );
    $l->clean(q{plover});
    # returns 'plover

=cut

sub remove_acceptable_attribute {
    my ( $self, $new_a, $args ) = @_;
    my $acceptable = $self->{acceptable_a};
    if ( ref($new_a) eq 'ARRAY' ) {
        foreach my $a ( @{$new_a} ) {
            $self->remove_acceptable_attribute( $a, $args );
        }
    }
    else {
        delete $acceptable->{$new_a};
    }
    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{

  "http://www.w3.org/TR/ html1/DTD/ html1-transitional.dtd">
};
            $self->{tidy_foot} = q{
};
            $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, "";
        }
    }
    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;
    $str =~ s/\%([0-9a-f]{2})/chr(hex($1))/egi;
    return $str if utf8::decode($str);
    return $orig;
}

sub _encode_utf8 {
    my $self    = shift;
    my $str     = shift;
    my $highbit = qr/[^\w\$-_.+!*'(),]/;
    $str =~ s/($highbit)/ sprintf ("%%%02X", ord($1)) /ge;
    utf8::upgrade($str);
    return $str;
}

=head1 SEE ALSO

There are a number of tools designed for sanitizing HTML, some of which
may be better suited than HTML::Laundry to particular circumstances. In
addition to L, you may want to consider
L, an C-based module designed
solely for the purposes of  sanitizing HTML from potential XSS attack vectors;
L, a whitelist-based, pure-Perl module; or
L, an HTML tag whitelist using C.

=head1 AUTHOR

Steve Cook, C<<  >>

=head1 BUGS

Please report any bugs or feature requests on the GitHub page for this project,
http://github.com/snark/html-laundry.

=head1 ACKNOWLEDGMENTS

Thanks to Dave Cross and Vera Tobin.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc HTML::Laundry

=head1 COPYRIGHT & LICENSE

Copyright 2009 Six Apart, Ltd., all rights reserved.

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

=cut

1;    # End of HTML::Laundry