/[cwmp]/google/trunk/lib/CWMP/Request.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /google/trunk/lib/CWMP/Request.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

google/lib/CWMP/Request.pm revision 62 by dpavlin, Wed Jun 20 21:37:52 2007 UTC google/trunk/lib/CWMP/Request.pm revision 227 by dpavlin, Sun Nov 25 18:51:26 2007 UTC
# Line 6  use strict; Line 6  use strict;
6  use XML::Rules;  use XML::Rules;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use Carp qw/confess cluck/;  use Carp qw/confess cluck/;
9    use Class::Trigger;
10    
11  =head1 NAME  #use Devel::LeakTrace::Fast;
   
 CWMP::Request - parse SOAP request  
12    
13  =head1 METHODS  =head1 NAME
14    
15  =head2 _tag  CWMP::Request - parse SOAP request metods
16    
17  Get value of tag. Tag name is case insensitive (don't ask why),  =head1 CPE metods
 we ignore namespaces and can take optional C<sub_key>  
 (usually C<_content>).  
18    
19    _tag( $tag_hash, $name, $sub_key )  All methods described below call triggers with same name
20    
21  =cut  =cut
22    
23  sub _tag {  our $state;     # FIXME check this!
         my ( $tag_hash, $name, $sub_key ) = @_;  
         confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' );  
         $name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0];  
 #       $name =~ s/^\w+://;  
         if ( defined $tag_hash->{$name} ) {  
                 if ( ! defined $sub_key ) {  
                         return $tag_hash->{$name};  
                 } elsif ( defined $tag_hash->{$name}->{$sub_key} ) {  
                         return $tag_hash->{$name}->{$sub_key};  
                 } else {  
                         return if ( $name =~ m/^value$/i );  
                         warn "can't find '$name/$sub_key' in ", dump( $tag_hash );  
                         return;  
                 }  
         } else {  
                 warn "can't find '$name' in ", dump( $tag_hash );  
                 return;  
         }  
 }  
   
 my $state;  
24    
25  my $parser = XML::Rules->new(  our $rules =  [
 #       start_rules => [  
 #               '^division_name,fax' => 'skip',  
 #       ],  
         namespaces => {  
                 'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',  
                 'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',  
                 'http://www.w3.org/2001/XMLSchema' => 'xsd',  
                 'http://www.w3.org/2001/XMLSchema-instance' => 'xsi',  
                 'urn:dslforum-org:cwmp-1-0' => '',  
         },  
         rules => [  
26                  #_default => 'content trim',                  #_default => 'content trim',
27                  x_default => sub {                  x_default => sub {
28                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
# Line 67  my $parser = XML::Rules->new( Line 32  my $parser = XML::Rules->new(
32                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
33                          $state->{ID} = $tag_hash->{_content};                          $state->{ID} = $tag_hash->{_content};
34                  },                  },
35                  #  
36                  # Inform                  'DeviceId' => sub {
                 #  
                 'Inform' => sub {  
                         $state->{_dispatch} = 'Inform';         # what reponse to call  
                 },  
                 qr/DeviceId/ => sub {  
37                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
38                          foreach my $name ( keys %$tag_hash ) {                          foreach my $name ( keys %$tag_hash ) {
39                                  next if $name eq '_content';                                  next if $name eq '_content';
# Line 82  my $parser = XML::Rules->new( Line 42  my $parser = XML::Rules->new(
42                                  $state->{DeviceID}->{ $key } = _tag( $tag_hash, $name, '_content' );                                  $state->{DeviceID}->{ $key } = _tag( $tag_hash, $name, '_content' );
43                          }                          }
44                  },                  },
45                  qr/EventStruct/ => sub {                  'EventStruct' => sub {
46                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
47                          push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content};                          push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content};
48                  },                  },
# Line 90  my $parser = XML::Rules->new( Line 50  my $parser = XML::Rules->new(
50                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
51                          $state->{$tag_name} = $tag_hash->{_content};                          $state->{$tag_name} = $tag_hash->{_content};
52                  },                  },
53                  qr/ParameterValueStruct/ => sub {                  'ParameterValueStruct' => sub {
54                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
55                          # Name/Value tags must be case insnesitive                          # Name/Value tags must be case insnesitive
56                          my $value = (grep( /value/i, keys %$tag_hash ))[0];                          my $value = (grep( /value/i, keys %$tag_hash ))[0];
57                          $state->{Parameter}->{ _tag($tag_hash, 'Name', '_content') } = _tag($tag_hash, 'Value', '_content' );                          $state->{Parameter}->{ _tag($tag_hash, 'Name', '_content') } = _tag($tag_hash, 'Value', '_content' );
58                            $state->{_trigger} = 'ParameterValue';
59                  },                  },
60                  #  
61                  # GetRPCMethodsResponse  ];
62                  #  
63    =head2 Inform
64    
65    Generate InformResponse to CPE
66    
67    =cut
68    
69    push @$rules,
70            'Inform' => sub {
71                    $state->{_dispatch} = 'InformResponse';         # what reponse to call
72                    $state->{_trigger} = 'Inform';
73            };
74    
75    =head2 GetRPCMethodsResponse
76    
77    =cut
78    
79    push @$rules,
80                  qr/^(?:^\w+:)*string$/ => 'content array',                  qr/^(?:^\w+:)*string$/ => 'content array',
81                  qr/MethodList/ => sub {                  'MethodList' => sub {
82                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
83                          $state->{MethodList} = _tag( $tag_hash, 'string' );                          $state->{MethodList} = _tag( $tag_hash, 'string' );
84                  },                                $state->{_trigger} = 'GetRPCMethodsResponse';
85                  #                  };
86                  # Fault  
87                  #  =head2 GetParameterNamesResponse
88                  qr/^Fault$/ => sub {  
89    =cut
90    
91    push @$rules,
92                    'ParameterInfoStruct' => sub {
93                            my ($tag_name, $tag_hash, $context, $parent_data) = @_;
94                            my $name = _tag($tag_hash, 'Name', '_content');
95                            my $writable = _tag($tag_hash, 'Writable', '_content' );
96    
97                            confess "need state" unless ( $state ); # don't remove!
98    
99                            $state->{ParameterInfo}->{$name} = $writable;
100    
101                            #warn "## state = dump( $state ), "\n";
102    
103                            $state->{_trigger} = 'GetParameterNamesResponse';
104                    };
105            
106    =head2 Fault
107    
108    =cut
109    
110    push @$rules,
111                    'Fault' => sub {
112                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
113                          $state->{Fault} = {                          $state->{Fault} = {
114                                  FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ),                                  FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ),
115                                  FaultString => _tag( $tag_hash, 'FaultString', '_content' ),                                  FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
116                          };                          };
117                          warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";                          warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
118                  }                          $state->{_trigger} = 'Fault';
119          ]                  };
120  );  
121    =head1 METHODS
122    
123  =head2 parse  =head2 parse
124    
# Line 130  sub parse { Line 132  sub parse {
132          my $xml = shift || confess "no xml?";          my $xml = shift || confess "no xml?";
133    
134          $state = {};          $state = {};
135    
136            my $parser = XML::Rules->new(
137    #               start_rules => [
138    #                       '^division_name,fax' => 'skip',
139    #               ],
140                    namespaces => {
141                            'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',
142                            'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',
143                            'http://www.w3.org/2001/XMLSchema' => 'xsd',
144                            'http://www.w3.org/2001/XMLSchema-instance' => 'xsi',
145                            'urn:dslforum-org:cwmp-1-0' => '',
146                    },
147                    rules => $rules,
148            );
149    
150            warn "## created $parser\n";
151    
152          $parser->parsestring( $xml );          $parser->parsestring( $xml );
153    
154            undef $parser;
155    
156            if ( my $trigger = $state->{_trigger} ) {
157                    warn "### call_trigger( $trigger )\n";
158                    $self->call_trigger( $trigger, $state );
159            }
160            # XXX don't propagate _trigger (useful?)
161            delete( $state->{_trigger} );
162          return $state;          return $state;
163  }  }
164    
165    =head2 _tag
166    
167    Get value of tag. Tag name is case insensitive (don't ask why),
168    we ignore namespaces and can take optional C<sub_key>
169    (usually C<_content>).
170    
171      _tag( $tag_hash, $name, $sub_key )
172    
173    =cut
174    
175    sub _tag {
176            my ( $tag_hash, $name, $sub_key ) = @_;
177            confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' );
178            $name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0];
179    #       $name =~ s/^\w+://;
180            if ( defined $tag_hash->{$name} ) {
181                    if ( ! defined $sub_key ) {
182                            return $tag_hash->{$name};
183                    } elsif ( defined $tag_hash->{$name}->{$sub_key} ) {
184                            return $tag_hash->{$name}->{$sub_key};
185                    } else {
186                            return if ( $name =~ m/^value$/i );
187                            warn "can't find '$name/$sub_key' in ", dump( $tag_hash );
188                            return;
189                    }
190            } else {
191                    warn "can't find '$name' in ", dump( $tag_hash );
192                    return;
193            }
194    }
195    
196  1;  1;
Legend:
Removed from v.62  
changed lines
  Added in v.227
  ViewVC Help
Powered by ViewVC 1.1.26