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