File Coverage

blib/lib/XML/SemanticDiff.pm

Criterion	Covered	Total	%
statement	9	11	81.8
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	13	15	86.6

package XML::SemanticDiff;
our $AUTHORITY = 'cpan:SHLOMIF';

use strict;
use warnings;

use 5.012;

our $VERSION = '1.0005';

use XML::Parser;


sub new {
    my ($proto, %args) = @_;
    my $class = ref($proto) || $proto;
    my $self = \%args;

    require XML::SemanticDiff::BasicHandler unless defined $args{diffhandler};

    bless ($self, $class);
    return $self;
}

sub _is_file
{
    my ($self, $specifier) = @_;
    return $specifier !~ /\n/g && -f $specifier;
}

sub _get_pathfinder_obj {
    my $self = shift;

    return XML::SemanticDiff::PathFinder::Obj->new();
}

sub read_xml {
    my $self = shift;

    my ($xml_specifier) = @_;

    if (ref($xml_specifier) eq 'HASH')
    {
        return $xml_specifier;
    }
    else
    {
        $self->{path_finder_obj} = $self->_get_pathfinder_obj();

        my $p = XML::Parser->new(
            Style => 'Stream',
            Pkg   => 'XML::SemanticDiff::PathFinder',
            'Non-Expat-Options' => $self,
            Namespaces => 1
        );

        my $ret =
            $self->_is_file($xml_specifier)
                ? $p->parsefile($xml_specifier)
                : $p->parse($xml_specifier)
                ;

        $self->{path_finder_obj} = undef;

        return $ret;
    }
}

sub _same_namespace
{
    my ($self, $to, $from) = @_;

    my $t_e = exists($to->{NamespaceURI});
    my $f_e = exists($from->{NamespaceURI});
    if (!$t_e && !$f_e)
    {
        return 1;
    }
    elsif ($t_e && $f_e)
    {
        return ($to->{NamespaceURI} eq $from->{NamespaceURI});
    }
    else
    {
        return 0;
    }
}

sub _match_xpath {
    my $self = shift;
    my ($xpath, $flat_name) = @_;
    my @x_way = split /\//, $xpath;
    my @f_way = split /\//, $flat_name;
    for my $i (0..$#x_way) {
        $x_way[$i]=~s/.*?://g;
    }
    for my $i (0..$#f_way) {
        $f_way[$i]=~s/\[.*?\]$//g;
    }
    return 0 if $#x_way > $#f_way;
    for my $i (0..$#x_way) {
        if ($x_way[$i] ne $f_way[$i]) {
            return 0;
        }
    }
    return 1;
}

# Okay, it's pretty basic...
#
# We flatten each doc tree to a Perl hash where the keys are "fully qualified"
# XPath expressions (/root[1]/element[3]) that represent the unique location
# of each XML element, then compare the two hashes.
#
# Just loop over all the elements of the first hash- if the same key exists
# in the second, you compare the text and attributes and delete it. Any
# keys not found in the second hash are declared 'missing', and any keys leftover
# in the second hash after looping through the elements in the first are 'rogues'.

sub compare {
    my $self = shift;
    my ($from_xml, $to_xml) = @_;

    my $from_doc = $self->read_xml($from_xml);
    my $to_doc = $self->read_xml($to_xml);

    my @warnings = ();

    my $handler = $self->{diffhandler} || XML::SemanticDiff::BasicHandler->new(%$self);

    # drop away nodes matching xpaths to be ignored
    if (defined $self->{ignorexpath}) {
        my $ignore = $self->{ignorexpath};
        for my $path (@$ignore) {
            for my $ref ($from_doc, $to_doc) {
                for my $key (keys %$ref) {
                    if ($self->_match_xpath($path, $key)) {
                        delete $ref->{$key};
                    }
                }
            }
        }
    }

    # fire the init handler
    push (@warnings, $handler->init($self)) if $handler->can('init');

    # loop the elements
    foreach my $element (sort keys (%$from_doc)) {

        # element existence check
        if (defined $to_doc->{$element}) {

            # element value test
            unless ($from_doc->{$element}->{TextChecksum} eq $to_doc->{$element}->{TextChecksum}) {
                push (@warnings, $handler->element_value($element,
                                                         $to_doc->{$element},
                                                         $from_doc->{$element}))
                          if $handler->can('element_value');
            }

            # namespace test
            unless ($self->_same_namespace($from_doc->{$element},$to_doc->{$element})) {
                push (@warnings, $handler->namespace_uri($element,
                                                         $to_doc->{$element},
                                                         $from_doc->{$element}))
                           if $handler->can('namespace_uri');
            }

            # attribute tests
            foreach my $attr (keys(%{$from_doc->{$element}->{Attributes}})) {

                 # attr existence check
                 if (defined ($to_doc->{$element}->{Attributes}->{$attr})) {

                     # attr value test
                     if ($to_doc->{$element}->{Attributes}->{$attr} ne $from_doc->{$element}->{Attributes}->{$attr}){
                        push (@warnings, $handler->attribute_value($attr,
                                                                   $element,
                                                                   $to_doc->{$element},
                                                                   $from_doc->{$element}))
                              if $handler->can('attribute_value');
                     }
                     delete $to_doc->{$element}->{Attributes}->{$attr};
                 }
                 else {
                     push (@warnings, $handler->missing_attribute($attr,
                                                                  $element,
                                                                  $to_doc->{$element},
                                                                  $from_doc->{$element}))
                           if $handler->can('missing_attribute');
                 }
            }

            # rogue attrs
            foreach my $leftover (keys(%{$to_doc->{$element}->{Attributes}})) {
                push (@warnings, $handler->rogue_attribute($leftover,
                                                           $element,
                                                           $to_doc->{$element},
                                                           $from_doc->{$element}))
                     if $handler->can('rogue_attribute');
            }

            delete $to_doc->{$element};
        }
        else {
            push (@warnings, $handler->missing_element($element, $from_doc->{$element}))
                      if $handler->can('missing_element');
        }
    }

    # rogue elements
    foreach my $leftover ( keys (%$to_doc) ) {
        push (@warnings, $handler->rogue_element($leftover, $to_doc->{$leftover}))
             if $handler->can('rogue_element');
    }

    push (@warnings, $handler->final($self)) if $handler->can('final');

    return @warnings;
}

1;

package XML::SemanticDiff::PathFinder;
our $AUTHORITY = 'cpan:SHLOMIF';

foreach my $func (qw(StartTag EndTag Text StartDocument EndDocument PI))
{
    no strict 'refs';
    *{__PACKAGE__.'::'.$func} = sub {
        my $expat = shift;
        return $expat->{'Non-Expat-Options'}->{path_finder_obj}->$func(
            $expat, @_
        );
    };
}

package XML::SemanticDiff::PathFinder::Obj;
our $AUTHORITY = 'cpan:SHLOMIF';

use strict;

use Digest::MD5  qw(md5_base64);

use Encode qw(encode_utf8);

foreach my $accessor (qw(descendents char_accumulator doc
    opts xml_context PI_position_index))
{
    no strict 'refs';
    *{__PACKAGE__.'::'.$accessor} = sub {
        my $self = shift;

        if (@_)
        {
            $self->{$accessor} = shift;
        }
        return $self->{$accessor};
    };
}

# PI_position_index is the position index for the PI's below - the processing
# instructions.

sub new {
    my $class = shift;

    my $self = {};
    bless $self, $class;

    $self->_init(@_);

    return $self;
}

sub _init {
    return 0;
}

sub StartTag {
    my ($self, $expat, $element) = @_;


    my %attrs = %_;

    my @context = $expat->context;
    my $context_length = scalar (@context);
    my $parent = $context[$context_length -1];
    push (@{$self->descendents()->{$parent}}, $element) if $parent;

    my $last_ctx_elem = $self->xml_context()->[-1] || { position_index => {}};

    push @{$self->xml_context()},
        {
            element => "$element",
            'index' => ++$last_ctx_elem->{position_index}->{"$element"},
            position_index => {},
        };

    my $test_context;

    # if (@context){
    #     $test_context = '/' . join ('/', map { $_ . '[' . $position_index->{$_} . ']' } @context);
    # }

    # $test_context .= '/' . $element . '[' . $position_index->{$element} . ']';

    $test_context = $self->_calc_test_context();

    $self->doc()->{$test_context} =
    {
        NamespaceURI => ($expat->namespace($element) || ""),
        Attributes   => \%attrs,
        ($self->opts()->{keeplinenums}
            ? ( TagStart => $expat->current_line)
            : ()
        ),
    };
}

sub _calc_test_context
{
    my $self = shift;

    return
        join("",
            map { "/". $_->{'element'} . "[" . $_->{'index'} . "]" }
            @{$self->xml_context()}
        );
}

sub EndTag {
    my ($self, $expat, $element) = @_;

    my @context = $expat->context;

    # if (@context){
    #    $test_context = '/' . join ('/', map { $_ . '[' . $position_index->{$_} . ']' } @context);
    #}
    # $test_context .= '/' . $element . '[' . $position_index->{$element} . ']';

    my $test_context = $self->_calc_test_context();

    my $text;
    if ( defined( $self->char_accumulator()->{$element} )) {
        $text = $self->char_accumulator()->{$element};
        delete $self->char_accumulator()->{$element};
    }
    $text ||= 'o';

#    warn "text is '$text' \n";
#    my $ctx = Digest::MD5->new;
#    $ctx->add("$text");
#    $self->doc()->{"$test_context"}->{TextChecksum} = $ctx->b64digest;

    $self->doc()->{"$test_context"}->{TextChecksum} = md5_base64(encode_utf8("$text"));
    if ($self->opts()->{keepdata}) {
        $self->doc()->{"$test_context"}->{CData} = $text;
    }


    if (defined ( $self->descendents()->{$element})) {
        my $seen = {};
        foreach my $child (@{$self->descendents()->{$element}}) {
            next if $seen->{$child};
            $seen->{$child}++;
        }
    }

    $self->doc()->{"$test_context"}->{TagEnd} = $expat->current_line if $self->opts()->{keeplinenums};

    pop(@{$self->xml_context()});
}

sub Text {
    my $self = shift;
    my $expat = shift;

    my $element = $expat->current_element;
    my $char = $_;

    $char =~ s/^\s*//;
    $char =~ s/\s*$//;
    $char =~ s/\s+/ /g;
    $self->char_accumulator()->{$element} .= $char if $char;

}

sub StartDocument {
    my $self = shift;
    my $expat = shift;
    $self->doc({});
    $self->descendents({});
    $self->char_accumulator({});
    $self->opts($expat->{'Non-Expat-Options'});
    $self->xml_context([]);
    $self->PI_position_index({});
}

sub EndDocument {
    my $self = shift;

    return $self->doc();
}


sub PI {
    my ($self, $expat, $target, $data) = @_;
    my $attrs = {};
    $self->PI_position_index()->{$target}++;

    foreach my $pair (split /\s+/, $data) {
        $attrs->{$1} = $2 if $pair =~ /^(.+?)=["'](.+?)["']$/;
    }

    my $slug = '?' . $target . '[' . $self->PI_position_index()->{$target} . ']';

    $self->doc()->{$slug} =
        {
            Attributes => ($attrs || {}),
            TextChecksum => "1",
            NamespaceURI => "",
            ( $self->opts()->{keeplinenums}
            ? (
                TagStart => $expat->current_line(),
                TagEnd => $expat->current_line(),
              )
            : ()
            ),
        };
}

1;

__END__