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