File Coverage

lib/XML/XPath/XMLParser.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::XPath::XMLParser;

$VERSION = '1.41';

use strict; use warnings;

use XML::Parser;
use XML::XPath::Node;
use XML::XPath::Node::Element;
use XML::XPath::Node::Text;
use XML::XPath::Node::Comment;
use XML::XPath::Node::PI;
use XML::XPath::Node::Attribute;
use XML::XPath::Node::Namespace;

my @options = qw(
        filename
        xml
        parser
        ioref
        );

my ($_current, $_namespaces_on);
my %IdNames;

use vars qw/$xmlns_ns $xml_ns/;

$xmlns_ns = "http://www.w3.org/2000/xmlns/";
$xml_ns = "http://www.w3.org/XML/1998/namespace";

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %args = @_;
    my %hash = map(( "_$_" => $args{$_} ), @options);
    bless \%hash, $class;
}

sub parse {
    my $self = shift;

    $self->{IdNames} = {};
    $self->{InScopeNamespaceStack} = [ {
            '_Default' => undef,
            'xmlns' => $xmlns_ns,
            'xml' => $xml_ns,
        } ];

    $self->{NodeStack} = [ ];

    $self->set_xml($_[0]) if $_[0];

    my $parser = $self->get_parser || XML::Parser->new(
            ErrorContext => 2,
            ParseParamEnt => $XML::XPath::ParseParamEnt,
            );

    $parser->setHandlers(
            Init => sub { $self->parse_init(@_) },
            Char => sub { $self->parse_char(@_) },
            Start => sub { $self->parse_start(@_) },
            End => sub { $self->parse_end(@_) },
            Final => sub { $self->parse_final(@_) },
            Proc => sub { $self->parse_pi(@_) },
            Comment => sub { $self->parse_comment(@_) },
            Attlist => sub { $self->parse_attlist(@_) },
            );

    my $toparse;
    if ($toparse = $self->get_filename) {
        return $parser->parsefile($toparse);
    }
    else {
        return $parser->parse($self->get_xml || $self->get_ioref);
    }
}

sub parsefile {
    my $self = shift;
    my ($filename) = @_;
    $self->set_filename($filename);
    $self->parse;
}

sub parse_init {
    my $self = shift;
    my $e = shift;
    my $document = XML::XPath::Node::Element->new();
    my $newns = XML::XPath::Node::Namespace->new('xml', $xml_ns);
    $document->appendNamespace($newns);
    $self->{current} = $self->{DOC_Node} = $document;
}

sub parse_final {
    my $self = shift;
    return $self->{DOC_Node};
}

sub parse_char {
    my $self = shift;
    my $e = shift;
    my $text = shift;

    my $parent = $self->{current};

    my $last = $parent->getLastChild;
    if ($last && $last->isTextNode) {
        # append to previous text node
        $last->appendText($text);
        return;
    }

    my $node = XML::XPath::Node::Text->new($text);
    $parent->appendChild($node, 1);
}

sub parse_start {
    my $self = shift;
    my $e = shift;
    my $tag = shift;

    push @{ $self->{InScopeNamespaceStack} },
         { %{ $self->{InScopeNamespaceStack}[-1] } };
    $self->_scan_namespaces(@_);

    my ($prefix, $namespace) = $self->_namespace($tag);

    my $node = XML::XPath::Node::Element->new($tag, $prefix);

    my @attributes;
    for (my $ii = 0; $ii < $#_; $ii += 2) {
	my ($name, $value) = ($_[$ii], $_[$ii+1]);
        if ($name =~ /^xmlns(:(.*))?$/) {
            # namespace node
            my $prefix = $2 || '#default';
#            warn "Creating NS node: $prefix = $value\n";
            my $newns = XML::XPath::Node::Namespace->new($prefix, $value);
            $node->appendNamespace($newns);
        }
        else {
	    my ($prefix, $namespace) = $self->_namespace($name);
            undef $namespace unless $prefix;

            my $newattr = XML::XPath::Node::Attribute->new($name, $value, $prefix);
            $node->appendAttribute($newattr, 1);
            if (exists($self->{IdNames}{$tag}) && ($self->{IdNames}{$tag} eq $name)) {
    #            warn "appending Id Element: $val for ", $node->getName, "\n";
                $self->{DOC_Node}->appendIdElement($value, $node);
            }
        }
    }

    $self->{current}->appendChild($node, 1);
    $self->{current} = $node;
}

sub parse_end {
    my $self = shift;
    my $e = shift;
    $self->{current} = $self->{current}->getParentNode;
}

sub parse_pi {
    my $self = shift;
    my $e = shift;
    my ($target, $data) = @_;
    my $node = XML::XPath::Node::PI->new($target, $data);
    $self->{current}->appendChild($node, 1);
}

sub parse_comment {
    my $self = shift;
    my $e = shift;
    my ($data) = @_;
    my $node = XML::XPath::Node::Comment->new($data);
    $self->{current}->appendChild($node, 1);
}

sub parse_attlist {
    my $self = shift;
    my $e = shift;
    my ($elname, $attname, $type, $default, $fixed) = @_;
    if ($type eq 'ID') {
        $self->{IdNames}{$elname} = $attname;
    }
}

sub _scan_namespaces {
    my ($self, %attributes) = @_;

    while (my ($attr_name, $value) = each %attributes) {
	if ($attr_name eq 'xmlns') {
	    $self->{InScopeNamespaceStack}[-1]{'_Default'} = $value;
	} elsif ($attr_name =~ /^xmlns:(.*)$/) {
	    my $prefix = $1;
	    $self->{InScopeNamespaceStack}[-1]{$prefix} = $value;
	}
    }
}

sub _namespace {
    my ($self, $name) = @_;

    my ($prefix, $localname) = split(/:/, $name);
    if (!defined($localname)) {
	if ($prefix eq 'xmlns') {
	    return '', undef;
	} else {
	    return '', $self->{InScopeNamespaceStack}[-1]{'_Default'};
	}
    } else {
	return $prefix, $self->{InScopeNamespaceStack}[-1]{$prefix};
    }
}

sub as_string {
    my $node = shift;
    $node->toString;
}

sub get_parser { shift->{_parser}; }
sub get_filename { shift->{_filename}; }
sub get_xml { shift->{_xml}; }
sub get_ioref { shift->{_ioref}; }

sub set_parser { $_[0]->{_parser} = $_[1]; }
sub set_filename { $_[0]->{_filename} = $_[1]; }
sub set_xml { $_[0]->{_xml} = $_[1]; }
sub set_ioref { $_[0]->{_ioref} = $_[1]; }

1;

__END__