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