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                                 my $hash = _hash_value $tree->{$node}->[$_];
  90
  91                                 if ( my $n = delete $hash->{Name} ) {
  92                                         my @keys = keys %$hash;
  93                                         if ( $#keys > 0 ) {
  94                                                 $state->{$name}->{$n} = $hash;
  95                                         } else {
  96                                                 $state->{$name}->{$n} = $hash->{ $keys[0] };
  97                                                 warn "using $keys[0] as value for $name.$n\n";
  98                                         }
  99                                 } else {
 100                                         push @{ $state->{$name} }, _hash_value $tree->{$node}->[$_]
 101                                                 foreach 0 .. $#{ $tree->{$node} };
 102                                 }
 103                         }
 104                         $dump = 1;
 105
 106                 } elsif ( $node =~ m/Inform/ ) {
 107
 108                         $state->{_dispatch} = 'InformResponse';
 109
 110                 } elsif ( ref($tree->{$node}) eq 'HASH' ) {
 111
 112                         warn "## recurse $node\n";
 113                         _walk( $tree->{$node} );
 114
 115                 }
 116
 117                 if ( $dump ) {
 118 #                       warn "XXX tree ",dump( $tree->{$node} );
 119                         warn "## state ",dump( $state );
 120                 }
 121         }
 122 }
 123
 124 sub parse {
 125         my $self = shift;
 126
 127         my $xml = shift || confess "no xml?";
 128
 129         $state = {};
 130         my $bare = XML::Bare->new( text => $xml );
 131         my $hash = $bare->parse();
 132
 133         _walk $hash;
 134 #warn "# parsed to ",dump($hash);
 135
 136         return $state;
 137 }
 138
 139 1;