File Coverage

blib/lib/XML/TreeBuilder.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

require 5;

package XML::TreeBuilder;

use warnings;
use strict;
use XML::Element ();
use XML::Parser  ();
use Carp;
use IO::File;
use XML::Catalog 1.02;
use File::Basename;
use File::Spec;
use vars qw(@ISA $VERSION);

$VERSION = '5.4';
@ISA     = ('XML::Element');

#==========================================================================
sub new {
    my ( $this, $arg ) = @_;
    my $class = ref($this) || $this;

    if ( $arg && ( ref($arg) ne 'HASH' ) ) {
        croak(
            q|new expects an anonymous hash, $t->new( { NoExpand => 1, ErrorContext => 2 } ), for it's parameters, not a |
                . ref($arg) );
    }

    my $NoExpand     = ( delete $arg->{NoExpand}     || undef );
    my $ErrorContext = ( delete $arg->{ErrorContext} || undef );
    my $catalog
        = (    delete $arg->{catalog}
            || $ENV{XML_CATALOG_FILES}
            || '/etc/xml/catalog' );
    my $debug = ( delete $arg->{debug} || undef );

    if ( %{$arg} ) {
        croak "unknown args: " . join( ", ", keys %{$arg} );
    }

    my $self = XML::Element->new('NIL');
    bless $self, $class;    # and rebless
    $self->{_element_class}      = 'XML::Element';
    $self->{_store_comments}     = 0;
    $self->{_store_pis}          = 0;
    $self->{_store_declarations} = 0;
    $self->{_store_cdata}        = 0;

    # have to let HTML::Element know there are encoded entities
    $XML::Element::encoded_content = $NoExpand if ($NoExpand);

    my @stack;

 # Compare the simplicity of this to the sheer nastiness of HTML::TreeBuilder!

    $self->{_xml_parser} = XML::Parser->new(
        Handlers => {
            Default => sub {

                # Stuff unexpanded entities back on to the stack as is.
                if ( ($NoExpand) && ( $_[1] =~ /&[^\;]+\;/ ) ) {
                    $stack[-1]->push_content( $_[1] );
                }
                return;
            },

            Start => sub {
                my $xp  = shift;
                my $str = $xp->original_string();
                if (@stack) {
                    my @args;
                    my $tag = shift(@_);
                    while (@_) {
                        my ( $attr, $val ) = splice( @_, 0, 2 );
## BUGBUG This dirty hack is because the $val from XML::Parser isn't correct when $NoExpand is set ... can we fix it?
## any entity in an attribute is lost
## given  $val is "this--attr" not "this-&FOO;-attr"
                        if ( $NoExpand && $str =~ /\s$attr="([^"]*\&[^"]*)"/ )
                        {
                            $val = $1;
                        }
                        push( @args, $attr, $val );
                    }

                    unshift( @args, $tag );
                    push @stack, $self->{_element_class}->new(@args);
                    $stack[-2]->push_content( $stack[-1] );
                }
                else {
                    $self->tag(shift);
                    while (@_) {
                        my ( $attr, $val ) = splice( @_, 0, 2 );
## BUGBUG This dirty hack is because the $val from XML::Parser isn't correct when $NoExpand is set ... can we fix it?
## any entity in an attribute is lost
## given  $val is "this--attr" not "this-&FOO;-attr"
                        if ( $NoExpand && $str =~ /\s$attr="([^"]*\&[^"]*)"/ )
                        {
                            $val = $1;
                        }
                        $self->attr( $attr, $val );
                    }
                    push @stack, $self;
                }
            },

            End => sub { pop @stack; return },

            Char => sub {

       # have to escape '&' if we have entities to catch things like &foo;
                if ( $_[1] eq '&' and $NoExpand ) {
                    $stack[-1]->push_content('&');
                }
                else {
                    $stack[-1]->push_content( $_[1] );
                }
            },

            Comment => sub {
                return unless $self->{_store_comments};
                ( @stack ? $stack[-1] : $self )
                    ->push_content( $self->{_element_class}
                        ->new( '~comment', 'text' => $_[1] ) );
                return;
            },

            Proc => sub {
                return unless $self->{'_store_pis'};
                ( @stack ? $stack[-1] : $self )
                    ->push_content( $self->{_element_class}
                        ->new( '~pi', 'text' => "$_[1] $_[2]" ) );
                return;
            },

            # And now, declarations:

            Attlist => sub {
                return unless $self->{_store_declarations};
                shift;
                ( @stack ? $stack[-1] : $self )->push_content(
                    $self->{_element_class}->new(
                        '~declaration',
                        'text' => join ' ',
                        'ATTLIST', @_
                    )
                );
                return;
            },

            Element => sub {
                return unless $self->{_store_declarations};
                shift;
                ( @stack ? $stack[-1] : $self )->push_content(
                    $self->{_element_class}->new(
                        '~declaration',
                        'text' => join ' ',
                        'ELEMENT', @_
                    )
                );
                return;
            },

            Doctype => sub {
                return unless $self->{_store_declarations};
                shift;
                ## Need this because different types set different array entries.
                no warnings 'uninitialized';
                ( @stack ? $stack[-1] : $self )->push_content(
                    $self->{_element_class}->new(
                        '~declaration',
                        'text' => join( ' ', ( 'DOCTYPE', @_ ) ),
                        type   => 'DOCTYPE',
                        mytag  => $_[0],
                        uri    => $_[1],
                        pid    => $_[2],
                    )
                );
                return;
            },

            Entity => sub {
                return unless $self->{_store_declarations};
                shift;
                ## Need this because different entity types set different array entries.
                no warnings 'uninitialized';
                ( @stack ? $stack[-1] : $self )->push_content(
                    $self->{_element_class}->new(
                        '~declaration',
                        'text' => join( ' ', ( 'ENTITY', @_ ) ),
                        type   => 'ENTITY',
                        name   => $_[0],
                        value  => $_[1],
                    )
                );
                return;
            },

            CdataStart => sub {
                return unless $self->{_store_cdata};
                shift;
                push @stack,
                    $self->{_element_class}->new( '~cdata', 'text' => $_[1] );
                $stack[-2]->push_content( $stack[-1] );
                return;
            },

            CdataEnd => sub {
                return unless $self->{_store_cdata};
                pop @stack;
                return;
            },

            ExternEnt => sub {
                return if ($NoExpand);
                my $xp = shift;
                my ( $base, $sysid, $pubid ) = @_;
                my $file = "$sysid";

                if ( $sysid =~ /^http:/ ) {
## BUGBUG need to catch when there is no local file
                    my $cat = XML::Catalog->new($catalog);
                    $file = $cat->resolve_public($pubid);
                    croak("Can't resolve '$pubid'")
                        if ( !defined($file) || $file eq '' );
                    $file =~ s/^file:\/\///;
                    my ( $filename, $directories, $suffix )
                        = fileparse($file);
                    $base = $directories;
                }
                else {
                    $sysid =~ s/^file:\/\/// if ( $sysid =~ /^file:/ );

                    if ( File::Spec->file_name_is_absolute($sysid) ) {
                        my ( $filename, $directories, $suffix )
                            = fileparse($sysid);
                        $base = $directories;
                    }
                    else {
                        my ( $filename, $directories, $suffix )
                            = fileparse($base);
                        $file = File::Spec->rel2abs( $sysid, $directories );
                    }
                }
                my $fh = new IO::File( $file, "r" );
                croak "$!" unless $fh;
                $xp->{_BaseStack} ||= [];
                $xp->{_FhStack}   ||= [];

                push( @{ $xp->{_BaseStack} }, $base );
                push( @{ $xp->{_FhStack} },   $fh );

                $xp->base($base);
                return ($fh);
            },

            ExternEntFin => sub {
                return if ($NoExpand);
                my ($xp) = shift;

                my $fh = pop( @{ $xp->{_FhStack} } );
                $fh->close if ($fh);

                my $base = pop( @{ $xp->{_BaseStack} } );
                $xp->base($base) if ($base);
                return;
            },

        },
        NoExpand      => $NoExpand,
        ErrorContext  => $ErrorContext,
        ParseParamEnt => !$NoExpand,
        NoLWP         => 0,
    );

    return $self;
}

#==========================================================================
sub _elem    # universal accessor...
{
    my ( $self, $elem, $val ) = @_;
    my $old = $self->{$elem};
    $self->{$elem} = $val if defined $val;
    return $old;
}

sub store_comments     { shift->_elem( '_store_comments',     @_ ); }
sub store_declarations { shift->_elem( '_store_declarations', @_ ); }
sub store_pis          { shift->_elem( '_store_pis',          @_ ); }
sub store_cdata        { shift->_elem( '_store_cdata',        @_ ); }

#==========================================================================

sub parse {
    shift->{_xml_parser}->parse(@_);
}

sub parse_file { shift->parsefile(@_) }    # alias

sub parsefile {
    shift->{_xml_parser}->parsefile(@_);
}

sub eof {
    delete shift->{_xml_parser};           # sure, why not?
}

#==========================================================================
1;

__END__