File Coverage

lib/XHTML/Util.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package XHTML::Util;
use strict;
use warnings;
no warnings "uninitialized";
use Carp;
use XML::LibXML;
use HTML::Tagset 3.02 ();
use HTML::Entities qw( encode_entities decode_entities );
use HTML::Selector::XPath ();
use HTML::DTD;
use Path::Class;
use Encode;
use Scalar::Util qw( blessed );
use HTML::TokeParser::Simple;
use XML::Normalize::LibXML qw( xml_normalize );
use LWP::Simple ();
use overload q{""} => sub { +shift->as_string }, fallback => 1;

our $VERSION = "0.99_08";
our $AUTHORITY = 'cpan:ASHLEY';
our $TITLE_ATTR = join("/", __PACKAGE__, $VERSION);

our $FRAGMENT_SELECTOR = "div[title='$TITLE_ATTR']";
our $FRAGMENT_XPATH = HTML::Selector::XPath::selector_to_xpath($FRAGMENT_SELECTOR);

my $isKnown = { %HTML::Tagset::isKnown }; # We modify this one.
my $emptyElement = \%HTML::Tagset::emptyElement;
my $isBodyElement = \%HTML::Tagset::isBodyElement;
my $isPhraseMarkup = \%HTML::Tagset::isPhraseMarkup;
#my $canTighten = \%HTML::Tagset::canTighten;
#my $isHeadElement = \%HTML::Tagset::isHeadElement;
#my $isHeadOrBodyElement = \%HTML::Tagset::isHeadOrBodyElement;
#my $isList = \%HTML::Tagset::isList;
#my $isTableElement = \%HTML::Tagset::isTableElement;
my $isFormElement = \%HTML::Tagset::isFormElement;
#my $p_closure_barriers = \@HTML::Tagset::p_closure_barriers;

# Accommodate HTML::TokeParser's idea of a "tag."
$isKnown->{"$_/"} = 1 for keys %{$emptyElement};
my $isBlockLevel = { map {; $_ => 1 }
                     grep { ! ( $isPhraseMarkup->{$_} || $isFormElement->{$_} ) }
                     keys %{$isBodyElement}
                 };
# use YAML; die YAML::Dump($isBlockLevel);

sub tags {
    grep { ! /\W/ }
        sort keys %HTML::Tagset::isKnown;
}

sub new {
    my $class = shift;
    my $arg = shift or croak "new requires an argument";
    my $self = bless {}, $class;

    if ( ref($arg) eq "SCALAR" )
    {
        $self->_parse( $$arg );
    }
    elsif ( blessed($arg) eq "Path::Class::File" )
    {
        $self->_parse( scalar $arg->slurp );
    }
    elsif ( blessed($arg) eq __PACKAGE__ )
    {
        $self->_parse( $arg->as_string ); # Cloning.
    }
    elsif ( blessed($arg) =~ /\AURI::https?/ )
    {
        $self->_parse( LWP::Simple::get($arg) );
    }
    elsif ( blessed($arg) and $arg->can("getlines") )
    {
        $self->_parse( join("", $arg->getlines) );
    }
    elsif ( ref($arg) eq 'GLOB' )
    {
        # $self->_parse( scalar Path::Class::File->new($arg)->slurp );
    }
    else
    {
        $self->_parse( scalar Path::Class::File->new($arg)->slurp );
    }
    $self;
}

sub debug {
    my $self = shift;
    $self->{_debug} = shift if @_;
    $self->{_debug} || 0;
}

sub as_string {
    my $self = shift;
    my @args = @_ ? @_ : ( 1, "UTF-8" );
    if ( $self->is_document )
    {
        return _trim( Encode::decode_utf8( $self->doc->serialize(@args) ) );
    }
    elsif ( $self->is_fragment )
    {
        croak "No root in document\n", $self->doc->serialize
            unless $self->root;

        my ( $fragment ) = $self->root->findnodes($FRAGMENT_XPATH);

        croak "No fragment...?\n", $self->doc->serialize
            unless $fragment;

        my $out = "";
        $out .= $_->serialize(@args) for $fragment->childNodes;

        return Encode::decode_utf8( _trim($out) );
    }
    else
    {
        die "No type was found, internal issue :(";
    }
}

sub is_document {
    +shift->{_type} eq "document";
}

sub is_fragment {
    +shift->{_type} eq "fragment";
}

sub _parse {
    my $self = shift;
    $self->{_sanitized} =
        $self->_sanitize( $self->{_original_string} = shift );

    if ( $self->{_original_string} =~ /\A(?:<\W[^>]+>|\s+)*
    {
        $self->{_type} = "document";
        $self->{_doc} = $self->parser->parse_html_string($self->{_sanitized});
        # Special case, doc contains ONLY 1 p and its first and last
        # child of body then we should replace it with the FRAGMENT
        # holder div.
    }
    else
    {
        # SHOULD we sanitize first?
        $self->{_type} = "fragment";

        $self->{_doc} = $self->parser
            ->parse_html_string(join("\n",
                                     "",
                                     sprintf('',
                                             $TITLE_ATTR
                                     ),
                                     $self->{_sanitized},
                                     #Encode::encode_utf8($self->{_sanitized}),
                                     '')
            );
    }

    $self->root->normalize;
    $self->doc;
}

sub root {
    +shift->doc->getDocumentElement;
}

sub doc {
    +shift->{_doc};
}

sub text {
    +shift->doc->getDocumentElement->textContent;
}

sub parser {
    my $self = shift;
    return $self->{_parser} if $self->{_parser};
    $self->{_parser} = XML::LibXML->new;
    $self->{_parser}->recover_silently(1);
    $self->{_parser}->keep_blanks(1);
    $self->{_parser};
}

sub is_valid {
    my $self = shift;
    return 1 if $self->doc->is_valid;
    # 321 debug about which DTD is being used.
    my $dtd_name = shift || "xhtml1-transitional";
    my $dtd_string = HTML::DTD->get_dtd("$dtd_name.dtd");
    $self->{_dtd} = XML::LibXML::Dtd->parse_string($dtd_string);
    return $self->doc->is_valid($self->{_dtd}) ? $self : undef;
}

sub validate {
    my $self = shift;
    return 1 if $self->is_valid;
    return $self->doc->validate($self->{_dtd});
}

sub _original_string {
    my $self = shift;
    $self->{_original_string} ||= shift;
#    $self->{_original_string} ||= Encode::encode_utf8( shift ); #321
    $self->{_original_string};
}

sub _return {
    my $self = shift; # 321 ARGS for serialize.
    xml_normalize( $self->doc );
    my $callers_wantarray = [ caller(1) ]->[5];
    return unless defined $callers_wantarray; # Void context.
    return $self;    # Should always return self?
}

sub fix {
    my $self = shift;
    return $self->_return if $self->is_valid;

    for my $fixable ( qw( img ) )
    {
        my $method = "_fix_$fixable";
        for my $node ( $self->root->findnodes("//$fixable") )
        {
            $self->$method($node);
        }
    }

    $self->is_valid()
        or carp "Could not fix the problems with this document";
    $self->validate();
    $self->_return;
}

sub _sanitize {
    my $self = shift;
    my $fragment = shift or return;
    #$fragment = Encode::decode_utf8($fragment);
    my $p = HTML::TokeParser::Simple->new(\$fragment);
    my $renew = "";
    my $in_body = 0;
  TOKEN:
    while ( my $token = $p->get_token )
    {
        #warn sprintf("%10s %10s %s\n",  $token->[-1], $token->get_tag, blessed($token));
        #no warnings "uninitialized";
        if ( $isKnown->{$token->get_tag} )
        {
            if ( $token->is_start_tag )
            {
                my @pair;
                for my $attr ( @{ $token->get_attrseq } )
                {
                    next if $attr eq "/";
                    my $value = encode_entities(decode_entities($token->get_attr($attr)));
                    push @pair, join("=",
                                     $attr,
                                     qq{"$value"});
                }
                $renew .= "<" . join(" ", $token->get_tag, @pair);
                $renew .= ( $token->get_attr("/") || $emptyElement->{$token->get_tag} ) ? "/>" : ">";
            }
            else
            {
                $renew .= $token->as_is;
            }
        }
        elsif ( $token->is_declaration or $token->is_pi )
        {
            $renew .= $token->as_is;
        }
        else
        {
            $renew .= encode_entities(decode_entities($token->as_is),'<>"&');
        }
    }
    return $renew;
}

sub body {
    [ shift->doc->findnodes("//body") ]->[0];
}

sub head {
    [ shift->doc->findnodes("//head") ]->[0];
}

sub as_fragment {
    my $self = shift;
    my ( $fragment ) = $self->doc->findnodes($FRAGMENT_XPATH);
    $fragment ||= $self->body;
    my $out = "";
    $out .= $_->serialize(1,"UTF-8") for $fragment->childNodes;
    return $out;
}

sub _make_selector {
    my $self = shift;
    my $selector = shift;
    unless ( $selector )
    {
        my $base = $self->is_fragment ? $FRAGMENT_SELECTOR : "body";
        $selector = "$base, $base *";
    }
    warn "Selector: $selector" if $self->debug > 2;
    $selector =~ m,\A/, ?
        $selector :
        HTML::Selector::XPath::selector_to_xpath($selector);
}

sub traverse {
    my $self = shift;
    my $xpath = $self->_make_selector(+shift) if @_ == 2;
    my $code = shift;

    if ( $xpath )
    {
        for my $node ( $self->root->findnodes("$xpath") )
        {
            $code->($node);
        }
    }
    else
    {
        $code->($self->root);
    }
    $self->_return;
}


sub enpara {
    my $self = shift;
    my $xpath = $self->_make_selector(+shift);
    my $root = $self->root;
    my $doc = $self->doc;

  NODE:
    for my $designated_enpara ( $root->findnodes("$xpath") )
    {
        # warn "FOUND ", $designated_enpara->nodeName, $/;
        # warn "*********", $designated_enpara->toString if $self->debug > 2;
        next unless $designated_enpara->nodeType == 1;
        next NODE if $designated_enpara->nodeName eq 'p';
        if ( $designated_enpara->nodeName eq 'pre' )  # I don't think so, honky.
        {
            # Expand or leave it alone? or ->validate it...?
            carp "It makes no sense to enpara within a ; skipping";
            next NODE;
        }
        next unless $isBlockLevel->{$designated_enpara->nodeName};

        $self->_enpara_this_nodes_content($designated_enpara, $doc);
    }
    $self->_enpara_this_nodes_content($root, $doc);
    $self->_return;
}

sub _enpara_this_nodes_content {
    my ( $self, $parent, $doc ) = @_;
    my $lastChild = $parent->lastChild;
    my @naked_block;
    for my $node ( $parent->childNodes )
    {
        if ( $isBlockLevel->{$node->nodeName}
             or
             $node->nodeName eq "a" # special case block level, so IGNORE
             and
             grep { $_->nodeName eq "img" } $node->childNodes
             )
        {
            next unless @naked_block; # nothing to enblock
            my $p = $doc->createElement("p");
            $p->setAttribute("enpara","enpara");
            $p->setAttribute("line",__LINE__) if $self->debug > 4;
            $p->appendChild($_) for @naked_block;
            $parent->insertBefore( $p, $node )
                if $p->textContent =~ /\S/;
            @naked_block = ();
        }
        elsif ( $node->nodeType == 3
                and
                $node->nodeValue =~ /(?:[^\S\n]*\n){2,}/
                )
        {
            my $text = $node->nodeValue;
            my @text_part = map { $doc->createTextNode($_) }
                split /([^\S\n]*\n){2,}/, $text;

            my @new_node;
            for ( my $x = 0; $x < @text_part; $x++ )
            {
                if ( $text_part[$x]->nodeValue =~ /\S/ )
                {
                    push @naked_block, $text_part[$x];
                }
                else # it's a blank newline node so _STOP_
                {
                    next unless @naked_block;
                    my $p = $doc->createElement("p");
                    $p->setAttribute("enpara","enpara");
                    $p->setAttribute("line",__LINE__) if $self->debug > 4;
                    $p->appendChild($_) for @naked_block;
                    @naked_block = ();
                    push @new_node, $p;
                }
            }
            if ( @new_node )
            {
                $parent->insertAfter($new_node[0], $node);
                for ( my $x = 1; $x < @new_node; $x++ )
                {
                    $parent->insertAfter($new_node[$x], $new_node[$x-1]);
                }
            }
            $node->unbindNode;
        }
        elsif ( $node->nodeName !~ /\Ahead|body\z/ ) # Hack? Fix real reason? 321
        {
            push @naked_block, $node; # if $node->nodeValue =~ /\S/;
        }

        if ( $node->isSameNode( $lastChild )
             and @naked_block )
        {
            my $p = $doc->createElement("p");
            $p->setAttribute("enpara","enpara");
            $p->setAttribute("line",__LINE__) if $self->debug > 4;
            $p->appendChild($_) for ( @naked_block );
            $parent->appendChild($p) if $p->textContent =~ /\S/;
        }
    }

    my $newline = $doc->createTextNode("\n");
    my $br = $doc->createElement("br");

    for my $p ( $parent->findnodes('//p[@enpara="enpara"]') )
    {
        $p->removeAttribute("enpara");
        $parent->insertBefore( $newline->cloneNode, $p );
        $parent->insertAfter( $newline->cloneNode, $p );

        my $frag = $doc->createDocumentFragment();

        my @kids = $p->childNodes();
        for ( my $i = 0; $i < @kids; $i++ )
        {
            my $kid = $kids[$i];
            next unless $kid->nodeName eq "#text";
            my $text = $kid->nodeValue;
            $text =~ s/\A\r?\n// if $i == 0;
            $text =~ s/\r?\n\z// if $i == $#kids;

            my @lines = map { $doc->createTextNode($_) }
                split /(\r?\n)/, $text;

            for ( my $i = 0; $i < @lines; $i++ )
            {
                $frag->appendChild($lines[$i]);
                unless ( $i == $#lines
                         or
                         $lines[$i]->nodeValue =~ /\A\r?\n\z/ )
                {
                    $frag->appendChild($br->cloneNode);
                }
            }
            $kid->replaceNode($frag);
        }
    }
}

sub _trim {
    s/\A\s+|\s+\z//g for @_;
    wantarray ? @_ : $_[0];
}

sub _fix_img {
    my ( $self, $img ) = @_;
    unless ( $img->hasAttribute("src") )
    {
        croak "There is no way to fix an image without a source";
    }
    unless ( $img->hasAttribute("alt") )
    {
        $img->setAttribute("alt", $img->getAttribute("src"));
    }
}

sub _fix_center {
    my ( $self, $center ) = @_;
    #  -->
    die "Unimplemented";
}

sub _make_selector_xpath {
    my $self = shift;
    my $selector = shift;
    my $base = $self->is_fragment ? $FRAGMENT_SELECTOR : "body";
    my $xpath = HTML::Selector::XPath::selector_to_xpath("$base $selector");
    warn "XPATH: $xpath\n" if $self->debug >= 5;
    return $xpath;
}

sub remove {
    my $self = shift;
    my $xpath = $self->_make_selector_xpath(@_);
    for my $node ( $self->root->findnodes($xpath) )
    {
        $node->parentNode->removeChild($node);
    }
    $self->_return;
}

sub strip_tags {
    my $self = shift;
    my $xpath = $self->_make_selector_xpath(@_);

    for my $node ( $self->root->findnodes($xpath) )
    {
        my $fragment = $self->doc->createDocumentFragment;
        for my $n ( $node->childNodes )
        {
            $fragment->appendChild($n);
        }
        $node->replaceNode($fragment);
    }
    $self->_return;
}

sub same_same {
    my $self = shift;
    my $other = shift;
    my $self2 = blessed($other) eq __PACKAGE__ ?
        $other : __PACKAGE__->new($other);

    $self->parser->keep_blanks(0);

    my $one = $self->parser->parse_string($self->root->serialize(0))->serialize(0);
    my $two = $self->parser->parse_string($self2->root->serialize(0))->serialize(0);

    $self->parser->keep_blanks(1);

    $one eq $two or die "$one\n\n$two"
}

sub clone {
    my $self = shift;
    my $class = blessed($self);
    $class->new($self);
}

1;

__END__