From 3ed6a7db9923bbc2b4a9747e97c8928a2f2fcae6 Mon Sep 17 00:00:00 2001 From: Dobrica Pavlinusic Date: Sun, 7 Mar 2010 19:08:37 +0000 Subject: [PATCH] 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 --- lib/CWMP/Parser.pm | 139 +++++++++++++++++++++++++++++++++++++++++++++ t/10-parser.t | 78 +++++++++++++++++++++++++ 2 files changed, 217 insertions(+) create mode 100644 lib/CWMP/Parser.pm create mode 100755 t/10-parser.t diff --git a/lib/CWMP/Parser.pm b/lib/CWMP/Parser.pm new file mode 100644 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, 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 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; + -- 2.20.1