/[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 203 by dpavlin, Wed Nov 14 21:55:24 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
17    
18  =head2 _tag  All methods described below call triggers with same name
   
 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>).  
   
   _tag( $tag_hash, $name, $sub_key )  
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 {
                 #  
                 'Inform' => sub {  
                         $state->{_dispatch} = 'Inform';         # what reponse to call  
                 },  
                 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 80  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 88  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                            # XXX dragons ahead: convert name to tree rewriting it into perl
101                            my $s = '$state->{ParameterInfo}->' . $tree->name2perl( $name ) . "->{writable} = $writable;";
102                            eval "$s";
103                            confess "can't eval $s : $@" if ($@);
104    
105                            #warn "## state = dump( $state ), "\n";
106    
107                            $state->{_trigger} = 'GetParameterNamesResponse';
108                    };
109            
110    =head2 Fault
111    
112    =cut
113    
114    push @$rules,
115                    'Fault' => sub {
116                            my ($tag_name, $tag_hash, $context, $parent_data) = @_;
117                            $state->{Fault} = {
118                                    FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ),
119                                    FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
120                            };
121                            warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
122                            $state->{_trigger} = 'Fault';
123                    };
124    
125    my $parser = XML::Rules->new(
126    #       start_rules => [
127    #               '^division_name,fax' => 'skip',
128    #       ],
129            namespaces => {
130                    'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',
131                    'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',
132                    'http://www.w3.org/2001/XMLSchema' => 'xsd',
133                    'http://www.w3.org/2001/XMLSchema-instance' => 'xsi',
134                    'urn:dslforum-org:cwmp-1-0' => '',
135            },
136            rules => $rules,
137  );  );
138    
139    =head1 METHODS
140    
141  =head2 parse  =head2 parse
142    
143    my $state = CWMP::Request->parse( "<soap>request</soap>" );    my $state = CWMP::Request->parse( "<soap>request</soap>" );
# Line 118  sub parse { Line 151  sub parse {
151    
152          $state = {};          $state = {};
153          $parser->parsestring( $xml );          $parser->parsestring( $xml );
154            if ( my $trigger = $state->{_trigger} ) {
155                    warn "### call_trigger( $trigger )\n";
156                    $self->call_trigger( $trigger, $state );
157            }
158            # XXX don't propagate _trigger (useful?)
159            delete( $state->{_trigger} );
160          return $state;          return $state;
161  }  }
162    
163    =head2 _tag
164    
165    Get value of tag. Tag name is case insensitive (don't ask why),
166    we ignore namespaces and can take optional C<sub_key>
167    (usually C<_content>).
168    
169      _tag( $tag_hash, $name, $sub_key )
170    
171    =cut
172    
173    sub _tag {
174            my ( $tag_hash, $name, $sub_key ) = @_;
175            confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' );
176            $name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0];
177    #       $name =~ s/^\w+://;
178            if ( defined $tag_hash->{$name} ) {
179                    if ( ! defined $sub_key ) {
180                            return $tag_hash->{$name};
181                    } elsif ( defined $tag_hash->{$name}->{$sub_key} ) {
182                            return $tag_hash->{$name}->{$sub_key};
183                    } else {
184                            return if ( $name =~ m/^value$/i );
185                            warn "can't find '$name/$sub_key' in ", dump( $tag_hash );
186                            return;
187                    }
188            } else {
189                    warn "can't find '$name' in ", dump( $tag_hash );
190                    return;
191            }
192    }
193    
194  1;  1;
Legend:
Removed from v.36  
changed lines
  Added in v.203
  ViewVC Help
Powered by ViewVC 1.1.26