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