new XML parser based on XML::Bare

This switch from XML::Rules (which is nice, btw) is needed because Expat
parser userd by XML::Rules can't deal with invalid binary XML

git-svn-id: https://perl-cwmp.googlecode.com/svn/trunk@260 836a5e1a-633d-0410-964b-294494ad4392

diff --git a/lib/CWMP/Parser.pm b/lib/CWMP/Parser.pm
new file mode 100644 (file)
index 0000000..72b96f9
--- /dev/null
+++ b/lib/CWMP/Parser.pm
@@ -0,0 +1,139 @@
+package CWMP::Parser;
+
+use warnings;
+use strict;
+
+use XML::Bare;
+use Data::Dump qw/dump/;
+use Carp qw/confess cluck/;
+
+=head1 NAME
+
+CWMP::Parser - parse SOAP request XML
+
+=head1 DESCRIPTION
+
+Design is based on my expirience with L<XML::Rules>, but show-stopper
+was it's inability to parse invalid XML returned by some devices.
+
+=cut
+
+our $state;    # FIXME check this!
+
+sub _get_array {
+       my ( $tree ) = @_;
+
+       my @out;
+
+       foreach my $n ( keys %$tree ) {
+               next unless ref($tree->{$n}) eq 'ARRAY';
+               @out = map { $_->{value} } @{ $tree->{$n} };
+               last;
+       }
+
+       die "no array in ",dump($tree) unless @out;
+
+       return @out;
+}
+
+sub _hash_value {
+       my ( $tree ) = @_;
+       my $hash;
+       foreach my $n ( keys %$tree ) {
+               next unless ref($tree->{$n}) eq 'HASH';
+               $hash->{$n} = $tree->{$n}->{value};
+       }
+       die "no hash value in ",dump($hash) unless $hash;
+       return $hash;
+}
+
+sub _walk {
+       my ( $tree ) = @_;
+
+       foreach my $node ( keys %$tree ) {
+               next if $node =~ m/^_/;
+
+               my $dump = 0;
+
+               if ( $node =~ m/GetRPCMethodsResponse/ ) {
+
+                       $state->{MethodList} = [ _get_array( $tree->{$node}->{MethodList} ) ];
+                       $dump = 1;
+
+               } elsif ( $node =~ m/(ID|MaxEnvelopes|CurrentTime|RetryCount)/ ) {
+
+                       $state->{$1} = $tree->{$node}->{value};
+                       chomp $state->{$1};
+                       $dump = 1;
+
+               } elsif ( $node =~ m/(DeviceId)/ ) {
+
+                       $state->{$1} = _hash_value $tree->{$node};
+                       $dump = 1;
+
+               } elsif ( $node =~ m/(Fault)/ && ! defined $tree->{$node}->{detail} ) {
+
+                       $state->{$1} = _hash_value $tree->{$node};
+                       $dump = 1;
+
+               } elsif ( $node =~ m/(EventStruct|ParameterValueStruct|ParameterInfoStruct)/ ) {
+
+                       my $name = $1;
+                       $name =~ s/Struct//;
+                       $name =~ s/Value//;
+
+                       if ( ref $tree->{$node} eq 'HASH' ) {
+                               push @{ $state->{$name} }, _hash_value $tree->{$node};
+                       } elsif ( ref $tree->{$node} eq 'ARRAY' ) {
+
+                               my $hash = _hash_value $tree->{$node}->[$_];
+
+                               if ( my $n = delete $hash->{Name} ) {
+                                       my @keys = keys %$hash;
+                                       if ( $#keys > 0 ) {
+                                               $state->{$name}->{$n} = $hash;
+                                       } else {
+                                               $state->{$name}->{$n} = $hash->{ $keys[0] };
+                                               warn "using $keys[0] as value for $name.$n\n";
+                                       }
+                               } else {
+                                       push @{ $state->{$name} }, _hash_value $tree->{$node}->[$_]
+                                               foreach 0 .. $#{ $tree->{$node} };
+                               }
+                       }
+                       $dump = 1;
+
+               } elsif ( $node =~ m/Inform/ ) {
+
+                       $state->{_dispatch} = 'InformResponse';
+
+               } elsif ( ref($tree->{$node}) eq 'HASH' ) {
+
+                       warn "## recurse $node\n";
+                       _walk( $tree->{$node} );
+
+               }
+       
+               if ( $dump ) {
+#                      warn "XXX tree ",dump( $tree->{$node} );
+                       warn "## state ",dump( $state );
+               }
+       }
+}
+
+sub parse {
+       my $self = shift;
+
+       my $xml = shift || confess "no xml?";
+
+       $state = {};
+       my $bare = XML::Bare->new( text => $xml );
+       my $hash = $bare->parse();
+
+       _walk $hash;
+#warn "# parsed to ",dump($hash);
+
+       return $state;
+}
+
+1;

diff --git a/t/10-parser.t b/t/10-parser.t
new file mode 100755 (executable)
index 0000000..3b94831
--- /dev/null
+++ b/t/10-parser.t
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+my $debug = shift @ARGV;
+
+use Test::More tests => 73;
+use Data::Dump qw/dump/;
+use Cwd qw/abs_path/;
+use File::Slurp;
+use lib 'lib';
+
+# XML::Rules doesn't like it!
+#use Devel::LeakTrace::Fast;
+
+BEGIN {
+       use_ok('CWMP::Parser');
+}
+
+my @models = ( qw/SpeedTouch-706 SpeedTouch-780/ );
+
+ok( $#models + 1, 'got models' );
+
+ok(my $abs_path = abs_path($0), "abs_path");
+$abs_path =~ s!/[^/]*$!/!;     #!fix-vim
+
+my $path2method;
+my $triggers_count;
+
+sub file_is_deeply {
+       my ( $path ) = @_;
+
+       ok( my $xml = read_file( $path ), "read_file( $path )" );
+
+       diag $xml if $debug;
+
+       ok( my $trigger = $path2method->{$path}, "path2method($path)" );
+
+       ok( my $state = CWMP::Parser->parse( $xml ), 'parse' );
+
+       my $dump_path = $path;
+       $dump_path =~ s/\.xml/\.pl/;
+
+       write_file( $dump_path, dump( $state ) ) unless ( -e $dump_path );
+
+       diag "$path ? $dump_path" if $debug;
+
+       ok( my $hash = read_file( $dump_path ), "read_file( $dump_path )" );
+       ok ( $hash = eval "$hash", 'eval' );
+
+       is_deeply( $state, $hash, 'same' );
+}
+
+foreach my $model ( @models ) {
+
+       my $dir = "$abs_path/$model/";
+       opendir(DIR, $dir) || die "can't opendir $dir: $!";
+       my @xmls = map {
+               my $path = "$dir/$_";
+               my $method = $_;
+               $method =~ s/\.xml$//;
+               $path2method->{$path} = $method;
+               $path;
+       } grep { /\.xml$/ && -f "$dir/$_" } readdir(DIR);
+       closedir DIR;
+
+       diag "$model has ", $#xmls + 1, " xml tests";
+
+       ok( $#xmls, "xmls" );
+
+       foreach my $xml_path ( @xmls ) {
+               ok ( $xml_path, 'xml path' );
+               file_is_deeply( $xml_path );
+       }
+}
+
+diag "triggers_count = ",dump( $triggers_count ) if $debug;
+