[MOBY-guts] biomoby commit
Eddie Kawas
kawas at dev.open-bio.org
Tue Dec 2 18:53:46 UTC 2008
kawas
Tue Dec 2 13:53:46 EST 2008
Update of /home/repository/moby/moby-live/Perl/MOBY-Server/lib/MOBY/Client
In directory dev.open-bio.org:/tmp/cvs-serv6685/Perl/MOBY-Server/lib/MOBY/Client
Modified Files:
MobyUnitTest.pm
Log Message:
removed logic used to diff XML doms and instead use a module XML::SemanticCompare to do the diff
moby-live/Perl/MOBY-Server/lib/MOBY/Client MobyUnitTest.pm,1.3,1.4
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY-Server/lib/MOBY/Client/MobyUnitTest.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- /home/repository/moby/moby-live/Perl/MOBY-Server/lib/MOBY/Client/MobyUnitTest.pm 2008/11/25 17:29:54 1.3
+++ /home/repository/moby/moby-live/Perl/MOBY-Server/lib/MOBY/Client/MobyUnitTest.pm 2008/12/02 18:53:46 1.4
@@ -10,6 +10,7 @@
use strict;
use Carp;
+use XML::SemanticCompare;
use vars qw /$VERSION/;
$VERSION = sprintf "%d.%02d", q$Revision$ =~ /: (\d+)\.(\d+)/;
@@ -19,7 +20,6 @@
#-----------------------------------------------------------------
# load all modules needed
#-----------------------------------------------------------------
-use XML::Simple;
use XML::LibXML;
use Data::Dumper;
@@ -150,139 +150,9 @@
sub _test_xml {
my ( $self, $xml ) = @_;
return undef if $self->expected_output =~ m//g;
-
- # create object
- my $xml_simple = new XML::Simple(
- ForceArray => 1,
- ForceContent => 1,
-
- #KeepRoot => 1,
- SuppressEmpty => 1,
- keyattr => []
- );
-
- # read both XML files into a HASH
- my $control = undef;
- my $test = undef;
-
- # check for invalid XML
- eval { $control = $xml_simple->XMLin( $self->expected_output ); };
- return undef if $@;
- # check for invalid XML
- eval { $test = $xml_simple->XMLin($xml); };
- return undef if $@;
- return $self->_compare_current_level( $control, $test, (), () );
-}
-
-#-----------------------------------------------------------------
-# _compare_current_level:
-# compares current level of data structures that represent XML
-# documents.
-# If the current level and all child levels match, a true value
-# is returned. Otherwise, undef is returned.
-#-----------------------------------------------------------------
-sub _compare_current_level {
-
- # $control is current level in hash
- # x_ns are the prefixes that we use
- my ( $self, $control, $test, $control_ns, $test_ns ) = @_;
-
- # if either hash is missing they arent equal
- return undef unless $control;
- return undef unless $test;
-
- # get the namespace prefix and uris at the current level
- # for each doc and remove from current level of hash
- for my $key ( keys %$control ) {
- next unless $key =~ m/^xmlns[:]?/;
- $control_ns->{''} = ${$control}->{$key} if $key eq 'xmlns';
- $control_ns->{$1} = ${$control}->{$key} if $key =~ m/xmlns\:(.*)$/g;
- delete $$control->{$key};
- }
- for my $key ( keys %$test ) {
- next unless $key =~ m/^xmlns[:]?/;
- $test_ns->{''} = ${$test}->{$key} if $key eq 'xmlns';
- $test_ns->{$1} = ${$test}->{$key} if $key =~ m/xmlns\:(.*)$/g;
- delete ${$test}->{$key};
- }
-
- # compare current level number of keys
- return undef unless (keys %$control) == (keys %$test);
-
- # number of keys are equal, so start comparing!
- my $matching_nodes = 0;
- for my $key ( keys %$control ) {
- my $success = 1;
- for my $test_key ( keys %$test ) {
- # does the key exist?
- # 'content' is a special case ... because its text content for a node
- if ( ($key eq $test_key and $key eq 'content' )
- or ($self->_get_prefixed_key( $test_key, $test_ns ) eq
- $self->_get_prefixed_key( $key, $control_ns )
- and $self->_get_prefixed_key( $key, $control_ns )))
- {
-
- # are we dealing with scalar values now or more nesting?
- if ( ref( ${$control}->{$key} ) eq 'ARRAY' ) {
- # both items should be an array
- next unless ref(${$test}->{$test_key}) eq 'ARRAY';
- # array sizes should match here ...
- next unless @{${$control}->{$key}} == @{${$test}->{$test_key}};
- # more nesting try matching child nodes
- my $child_matches = 0;
- foreach my $child ( @{ ${$control}->{$key} } ) {
- my $matched = undef;
- foreach my $test_child ( @{ ${$test}->{$test_key} } ) {
- $matched = $self->_compare_current_level( $child, $test_child, $control_ns, $test_ns );
- $child_matches++ if $matched;
- last if $matched;
- } # end inner foreach
- $matching_nodes++ if @{ ${$control}->{$key} } == $child_matches;
- }
- } else {
- # compare scalar values now
- # we dont care about whitespace, so we need to trim the text
- my $c_text = $self->_clear_whitespace(${$control}->{$key});
- my $t_text = $self->_clear_whitespace(${$test}->{$test_key});
- $matching_nodes++ if $c_text eq $t_text;
- last if $c_text eq $t_text;
- }
- }
- } #end inner for
- }
-
- # no differences found!
- return undef unless $matching_nodes == (keys %$control);
- return 1;
-}
-
-#-----------------------------------------------------------------
-# _clear_whitespace: a whitespace trim function
-#-----------------------------------------------------------------
-sub _clear_whitespace {
- my ($self, $text) = @_;
- $text =~ s/^\s+//;
- $text =~ s/\s+$//;
- return $text;
-}
-
-#-----------------------------------------------------------------
-# _get_prefixed_key:
-# goes through and tries to determine what the namespace URI
-# is for a prefix.
-# Once a URI is found, the prefix is swapped with URI and
-# returned.
-#-----------------------------------------------------------------
-sub _get_prefixed_key {
- my ( $self, $key, $ns_hash ) = @_;
- my $prefixed_key = $key;
- my $prefix = $1 if $key =~ m/^([\w]+)\:.*/;
- $prefixed_key =~ s/$prefix/$ns_hash->{$prefix}/ if $prefix;
-
- # check for default xmlns
- $prefixed_key = $ns_hash->{$prefix} . ":" . $key
- if not $prefix and defined $ns_hash->{$prefix};
- return $prefixed_key;
+ # compare the docs
+ my $sc = XML::SemanticCompare->new();
+ return $sc->compare($self->expected_output, $xml);
}
#-----------------------------------------------------------------
@@ -295,21 +165,8 @@
# empty xml, nothing to test
return undef if $xml =~ m//g;
#instantiate a parser
- my $parser = XML::LibXML->new();
- my $tree = undef;
- # try parsing a string or a file
- eval {$tree = $parser->parse_string($xml);};
- eval {$tree = $parser->parse_file($xml);} if $@;
- return undef if $@;
- my $root = $tree->getDocumentElement;
- # evaluate the xpath statement
- my $results = undef;
- eval {$results = $root->find($self->xpath); };
- return undef if $@;
- # no results?
- return undef unless $results;
- # got some hits!
- return 1;
+ my $sc = XML::SemanticCompare->new();
+ return $sc->test_xpath($self->xpath, $xml);
}
#-----------------------------------------------------------------
More information about the MOBY-guts
mailing list