/[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

revision 36 by dpavlin, Tue Jun 19 00:38:49 2007 UTC revision 93 by dpavlin, Sat Jun 23 09:20:03 2007 UTC
# Line 7  use XML::Rules; Line 7  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    
10    my $debug = 0;
11    
12  =head1 NAME  =head1 NAME
13    
14  CWMP::Request - parse SOAP request  CWMP::Request - parse SOAP request
# Line 44  sub _tag { Line 46  sub _tag {
46          }          }
47  }  }
48    
49  my $state;  our $state;     # FIXME check this!
50    
51  my $parser = XML::Rules->new(  my $parser = XML::Rules->new(
52  #       start_rules => [  #       start_rules => [
53  #               '^division_name,fax' => 'skip',  #               '^division_name,fax' => 'skip',
54  #       ],  #       ],
55          namespaces => {          namespaces => {
56  #               'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',                  'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv',
57  #               'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',                  'http://schemas.xmlsoap.org/soap/encoding/' => 'soap',
58                    'http://www.w3.org/2001/XMLSchema' => 'xsd',
59                    'http://www.w3.org/2001/XMLSchema-instance' => 'xsi',
60                  'urn:dslforum-org:cwmp-1-0' => '',                  'urn:dslforum-org:cwmp-1-0' => '',
61          },          },
62          rules => [          rules => [
# Line 69  my $parser = XML::Rules->new( Line 73  my $parser = XML::Rules->new(
73                  # Inform                  # Inform
74                  #                  #
75                  'Inform' => sub {                  'Inform' => sub {
76                          $state->{_dispatch} = 'Inform';         # what reponse to call                          $state->{_dispatch} = 'InformResponse';         # what reponse to call
77                  },                  },
78                  qr/DeviceId/ => sub {                  'DeviceId' => sub {
79                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
80                          foreach my $name ( keys %$tag_hash ) {                          foreach my $name ( keys %$tag_hash ) {
81                                  next if $name eq '_content';                                  next if $name eq '_content';
# Line 80  my $parser = XML::Rules->new( Line 84  my $parser = XML::Rules->new(
84                                  $state->{DeviceID}->{ $key } = _tag( $tag_hash, $name, '_content' );                                  $state->{DeviceID}->{ $key } = _tag( $tag_hash, $name, '_content' );
85                          }                          }
86                  },                  },
87                  qr/EventStruct/ => sub {                  'EventStruct' => sub {
88                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
89                          push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content};                          push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content};
90                  },                  },
# Line 88  my $parser = XML::Rules->new( Line 92  my $parser = XML::Rules->new(
92                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
93                          $state->{$tag_name} = $tag_hash->{_content};                          $state->{$tag_name} = $tag_hash->{_content};
94                  },                  },
95                  qr/ParameterValueStruct/ => sub {                  'ParameterValueStruct' => sub {
96                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
97                          # Name/Value tags must be case insnesitive                          # Name/Value tags must be case insnesitive
98                          my $value = (grep( /value/i, keys %$tag_hash ))[0];                          my $value = (grep( /value/i, keys %$tag_hash ))[0];
# Line 98  my $parser = XML::Rules->new( Line 102  my $parser = XML::Rules->new(
102                  # GetRPCMethodsResponse                  # GetRPCMethodsResponse
103                  #                  #
104                  qr/^(?:^\w+:)*string$/ => 'content array',                  qr/^(?:^\w+:)*string$/ => 'content array',
105                  qr/MethodList/ => sub {                  'MethodList' => sub {
106                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;                          my ($tag_name, $tag_hash, $context, $parent_data) = @_;
107                          $state->{MethodList} = _tag( $tag_hash, 'string' );                          $state->{MethodList} = _tag( $tag_hash, 'string' );
108                  },                        },
109                    #
110                    # GetParameterNamesResponse
111                    #
112                    'ParameterInfoStruct' => sub {
113                            my ($tag_name, $tag_hash, $context, $parent_data) = @_;
114                            my $name = _tag($tag_hash, 'Name', '_content');
115                            my $writable = _tag($tag_hash, 'Writable', '_content' );
116    
117                            confess "need state" unless ( $state ); # don't remove!
118    
119                            # XXX dragons ahead: convert name to tree rewriting it into perl
120    
121                            my $s = $name;
122                            warn "===> $name\n" if $debug;
123                            $s =~ s/^([^\.]+)/\$state->{ParameterInfo}->{'$1'}/;
124                            warn "---> $s\n"  if $debug;
125    
126                            my $stat;
127                            while ( $s =~ s/\.(\d+)/->[$1]/ ) {
128                                    $stat->{array}++;
129                                    warn "-\@-> $s\n" if $debug;
130                            }
131                            while ( $s =~ s/\.([a-zA-Z0-9_]+)/->{'$1'}/ ) {
132                                    $stat->{scalar}++;
133                                    warn "-\$-> $s\n" if $debug;
134    
135                            };
136                            $s .= "->{'writable'} = $writable;";
137    
138                            warn "## $name\n## tree: $s\n## stat: ",dump( $stat ), "\n" if $debug;
139    
140                            eval "$s";
141                            confess "can't eval $s : $@" if ($@);
142    
143                            #warn "## state = dump( $state ), "\n";
144                    },
145                    #
146                    # Fault
147                    #
148                    'Fault' => sub {
149                            my ($tag_name, $tag_hash, $context, $parent_data) = @_;
150                            $state->{Fault} = {
151                                    FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ),
152                                    FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
153                            };
154                            warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
155                    }
156          ]          ]
157  );  );
158    
Legend:
Removed from v.36  
changed lines
  Added in v.93
  ViewVC Help
Powered by ViewVC 1.1.26