lib/CWMP/Parser.pm

   1 package CWMP::Parser;
   2
   3 use warnings;
   4 use strict;
   5
   6 use XML::Bare;
   7 use Data::Dump qw/dump/;
   8 use Carp qw/confess cluck/;
   9
  10 =head1 NAME
  11
  12 CWMP::Parser - parse SOAP request XML
  13
  14 =head1 DESCRIPTION
  15
  16 Design is based on my expirience with L<XML::Rules>, but show-stopper
  17 was it's inability to parse invalid XML returned by some devices.
  18
  19 =cut
  20
  21 our $state;     # FIXME check this!
  22 my $debug = 0;
  23
  24 sub _get_array {
  25         my ( $tree ) = @_;
  26
  27         my @out;
  28
  29         foreach my $n ( keys %$tree ) {
  30                 next unless ref($tree->{$n}) eq 'ARRAY';
  31                 @out = map { $_->{value} } @{ $tree->{$n} };
  32                 last;
  33         }
  34
  35         die "no array in ",dump($tree) unless @out;
  36
  37         return @out;
  38 }
  39
  40 sub _hash_value {
  41         my ( $tree ) = @_;
  42         my $hash;
  43         foreach my $n ( keys %$tree ) {
  44                 next unless ref($tree->{$n}) eq 'HASH';
  45                 $hash->{$n} = $tree->{$n}->{value};
  46         }
  47         die "no hash value in ",dump($hash) unless $hash;
  48         return $hash;
  49 }
  50
  51 sub _walk {
  52         my ( $tree ) = @_;
  53
  54         foreach my $node ( keys %$tree ) {
  55                 next if $node =~ m/^_/;
  56
  57                 my $dump = 0;
  58
  59                 if ( $node =~ m/GetRPCMethodsResponse/ ) {
  60
  61                         $state->{MethodList} = [ _get_array( $tree->{$node}->{MethodList} ) ];
  62                         $dump = 1;
  63
  64                 } elsif ( $node =~ m/(ID|MaxEnvelopes|CurrentTime|RetryCount)/ ) {
  65
  66                         $state->{$1} = $tree->{$node}->{value};
  67                         chomp $state->{$1};
  68                         $dump = 1;
  69
  70                 } elsif ( $node =~ m/(DeviceId)/ ) {
  71
  72                         $state->{$1} = _hash_value $tree->{$node};
  73                         $dump = 1;
  74
  75                 } elsif ( $node =~ m/(Fault)/ && ! defined $tree->{$node}->{detail} ) {
  76
  77                         $state->{$1} = _hash_value $tree->{$node};
  78                         $dump = 1;
  79
  80                 } elsif ( $node =~ m/(EventStruct|ParameterValueStruct|ParameterInfoStruct)/ ) {
  81
  82                         my $name = $1;
  83                         $name =~ s/Struct//;
  84                         $name =~ s/Value//;
  85
  86                         my @struct;
  87
  88                         if ( ref $tree->{$node} eq 'HASH' ) {
  89                                 @struct = ( $tree->{$node} );
  90                         } elsif ( ref $tree->{$node} eq 'ARRAY' ) {
  91                                 @struct = @{ $tree->{$node} };
  92                         } else {
  93                                 die "don't know how to handle $node in ",dump($tree);
  94                         }
  95
  96                         foreach my $e ( @struct ) {
  97                                 my $hash = _hash_value $e;
  98
  99                                 if ( my $n = delete $hash->{Name} ) {
 100                                         my @keys = keys %$hash;
 101                                         if ( $#keys > 0 ) {
 102                                                 $state->{$name}->{$n} = $hash;
 103                                         } else {
 104                                                 $state->{$name}->{$n} = $hash->{ $keys[0] };
 105 #                                                       warn "using $keys[0] as value for $name.$n\n";
 106                                         }
 107                                 } else {
 108                                         push @{ $state->{$name} }, $hash;
 109                                 }
 110                         }
 111
 112                         $dump = 1;
 113
 114                 } elsif ( ref($tree->{$node}) eq 'HASH' ) {
 115
 116                         $state->{_dispatch} = 'InformResponse' if $node =~ m/Inform/;
 117
 118                         warn "## recurse $node\n" if $debug;
 119                         _walk( $tree->{$node} );
 120
 121                 }
 122
 123                 if ( $dump ) {
 124 #                       warn "XXX tree ",dump( $tree->{$node} );
 125                         warn "## state ",dump( $state ) if $debug;
 126                 }
 127         }
 128 }
 129
 130 sub parse {
 131         my $self = shift;
 132
 133         my $xml = shift || confess "no xml?";
 134
 135         $state = {};
 136
 137         my $bare = XML::Bare->new( text => $xml );
 138         my $hash = $bare->parse();
 139
 140         _walk $hash;
 141 #warn "# parsed to ",dump($hash);
 142
 143         return $state;
 144 }
 145
 146 1;