view release on metacpan or  search on metacpan

lib/XML/Compare.pm  view on Meta::CPAN

                _outit($l, 'namespaceURIs are different', $node1->namespaceURI(), $node2->namespaceURI());
                _die $l, 'namespaceURIs are different: (%s, %s)', $ns1, $ns2;
            }
        }
        elsif ( (!defined $ns1) and (!defined $ns2) ) {
            _same($l, 'namespaceURI (not defined for either node)');
        }
        else {
	    if ( $self->namespace_strict or defined $ns1 ) {
		_outit($l, 'namespaceURIs are defined/not defined', $ns1, $ns2);
		_die $l, 'namespaceURIs are defined/not defined: (%s, %s)', ($ns1 || '[undef]'), ($ns2 || '[undef]');
	    }
        }
    }

    # check the attribute list is the same length
    if ( $has->{attributes}{ref $node1} ) {

	my $in = $self->_ignore_nodes;
        # get just the Attrs and sort them by namespaceURI:localname
        my @attr1 = sort { _fullname($a) cmp _fullname($b) }
	    grep { (!$in) or (!exists $in->{$_->nodePath}) }
		grep { defined and $_->isa('XML::LibXML::Attr') }
		    $node1->attributes();

        my @attr2 = sort { _fullname($a) cmp _fullname($b) }
	    grep { (!$in) or (!exists $in->{$_->nodePath}) }
		grep { defined and $_->isa('XML::LibXML::Attr') }
		    $node2->attributes();

        if ( scalar @attr1 == scalar @attr2 ) {
            _same($l, 'attribute length (' . (scalar @attr1) . ')');
        }
        else {
            _die $l, 'attribute list lengths differ: (%d, %d)', scalar @attr1, scalar @attr2;
        }

        # for each attribute, check they are all the same
        my $total_attrs = scalar @attr1;
        for (my $i = 0; $i < scalar @attr1; $i++ ) {
            # recurse down (either an exception will be thrown, or all are correct
            $self->_are_nodes_same( [@$l,'@'.$attr1[$i]->name], $attr1[$i], $attr2[$i] );
        }
    }

    my $in = $self->_ignore_nodes;

    # don't need to compare or care about Comments
    my @nodes1 = grep { (!$in) or (!exists $in->{$_->nodePath}) }
	grep { (not $_->isa('XML::LibXML::Comment')) and
		   not ( $_->isa("XML::LibXML::Text") && ($_->data =~ /\A\s*\Z/) )
	       }
	    $node1->childNodes();

    my @nodes2 = grep { (!$in) or (!exists $in->{$_->nodePath}) }
	grep { (not $_->isa('XML::LibXML::Comment')) and
		   not ( $_->isa("XML::LibXML::Text") && ($_->data =~ /\A\s*\Z/) )
	       } $node2->childNodes();

    # firstly, convert all CData nodes to Text Nodes
    @nodes1 = _convert_cdata_to_text( @nodes1 );
    @nodes2 = _convert_cdata_to_text( @nodes2 );

    # append all the consecutive Text nodes
    @nodes1 = _squash_text_nodes( @nodes1 );
    @nodes2 = _squash_text_nodes( @nodes2 );

    # check that the nodes contain the same number of children
    if ( @nodes1 != @nodes2 ) {
        _die $l, 'different number of child nodes: (%d, %d)', scalar @nodes1, scalar @nodes2;
    }

    # foreach of it's children, compare them
    my $total_nodes = scalar @nodes1;
    for (my $i = 0; $i < $total_nodes; $i++ ) {
        # recurse down (either an exception will be thrown, or all are correct
	my $nn = $nodes1[$i]->nodeName;
	if ( grep { $_->nodeName eq $nn }
		 @nodes1[0..$i-1, $i+1..$#nodes1] ) {
	    $nn .= "[position()=".($i+1)."]";
	}
	$nn =~ s{#text}{text()};
        $self->_are_nodes_same( [@$l,$nn], $nodes1[$i], $nodes2[$i] );
    }

    _msg($l, '/');
    return 1;
}

# takes an array of nodes and converts all the CDATASection nodes into Text nodes
sub _convert_cdata_to_text {
    my @nodes = @_;
    my @new;
    foreach my $n ( @nodes ) {
	if ( ref $n eq 'XML::LibXML::CDATASection' ) {
	    $n = XML::LibXML::Text->new( $n->data() );
	}
	push @new, $n;
    }
    return @new;
}

# takes an array of nodes and concatenates all the Text nodes together
sub _squash_text_nodes {
    my @nodes = @_;
    my @new;
    my $last_type = '';
    foreach my $n ( @nodes ) {
	if ( $last_type eq 'XML::LibXML::Text' and ref $n eq 'XML::LibXML::Text' ) {
	    $n = XML::LibXML::Text->new( $new[-1]->data() . $n->data() );
	    $new[-1] = $n;
	}
	else {
	    push @new, $n;
	}
	$last_type = ref $n;
    }
    return @new;
}

sub _fullname {
    my ($node) = @_;
    my $name = '';
    $name .= $node->namespaceURI() . ':' if $node->namespaceURI();
    $name .= $node->localname();
    # print "name=$name\n";
    return $name;
}

sub _same {
    my ($l, $msg) = @_;
    return unless $VERBOSE;
    print '' . ('  ' x (@$l+1)) . "= $msg\n";
}

sub _msg {
    my ($l, $msg) = @_;
    return unless $VERBOSE;
    print ' ' . ('  ' x (@$l)) ._xpath($l). " $msg\n";
}

sub _outit {
    my ($l, $msg, $v1, $v2) = @_;
    return unless $VERBOSE;
    print '' . ('  ' x @$l) . "! " ._xpath($l)." $msg:\n";
    print '' . ('  ' x @$l) . '. ' . ($v1 || '[undef]') . "\n";
    print '' . ('  ' x @$l) . '. ' . ($v2 || '[undef]') . "\n";
}

1;
__END__