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