r218@brr: dpavlin | 2007-11-14 22:54:48 +0100

[perl-cwmp.git] / lib / CWMP / Request.pm

diff --git a/lib/CWMP/Request.pm b/lib/CWMP/Request.pm
index eb1b577..b85892d 100644 (file)
--- a/lib/CWMP/Request.pm
+++ b/lib/CWMP/Request.pm
@@ -7,60 +7,23 @@ use XML::Rules;
 use CWMP::Tree;
 use Data::Dump qw/dump/;
 use Carp qw/confess cluck/;
+use Class::Trigger;
 
 =head1 NAME
 
-CWMP::Request - parse SOAP request
+CWMP::Request - parse SOAP request metods
 
-=head1 METHODS
-
-=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>).
+=head1 CPE metods
 
-  _tag( $tag_hash, $name, $sub_key )
+All methods described below call triggers with same name
 
 =cut
 
-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;
-       }
-}
+my $tree = CWMP::Tree->new({ debug => 0 });
 
 our $state;    # FIXME check this!
 
-my $tree = CWMP::Tree->new({ debug => 0 });
-
-my $parser = XML::Rules->new(
-#      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 => [
+my $rules =  [
                #_default => 'content trim',
                x_default => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
@@ -70,12 +33,7 @@ my $parser = XML::Rules->new(
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        $state->{ID} = $tag_hash->{_content};
                },
-               #
-               # Inform
-               #
-               'Inform' => sub {
-                       $state->{_dispatch} = 'InformResponse';         # what reponse to call
-               },
+
                'DeviceId' => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        foreach my $name ( keys %$tag_hash ) {
@@ -98,18 +56,40 @@ my $parser = XML::Rules->new(
                        # Name/Value tags must be case insnesitive
                        my $value = (grep( /value/i, keys %$tag_hash ))[0];
                        $state->{Parameter}->{ _tag($tag_hash, 'Name', '_content') } = _tag($tag_hash, 'Value', '_content' );
+                       $state->{_trigger} = 'ParameterValue';
                },
-               #
-               # GetRPCMethodsResponse
-               #
+
+];
+
+=head2 Inform
+
+Generate InformResponse to CPE
+
+=cut
+
+push @$rules,
+       'Inform' => sub {
+               $state->{_dispatch} = 'InformResponse';         # what reponse to call
+               $state->{_trigger} = 'Inform';
+       };
+
+=head2 GetRPCMethodsResponse
+
+=cut
+
+push @$rules,
                qr/^(?:^\w+:)*string$/ => 'content array',
                'MethodList' => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        $state->{MethodList} = _tag( $tag_hash, 'string' );
-               },
-               #
-               # GetParameterNamesResponse
-               #
+                       $state->{_trigger} = 'GetRPCMethodsResponse';
+               };
+
+=head2 GetParameterNamesResponse
+
+=cut
+
+push @$rules,
                'ParameterInfoStruct' => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        my $name = _tag($tag_hash, 'Name', '_content');
@@ -123,10 +103,15 @@ my $parser = XML::Rules->new(
                        confess "can't eval $s : $@" if ($@);
 
                        #warn "## state = dump( $state ), "\n";
-               },
-               #
-               # Fault
-               #
+
+                       $state->{_trigger} = 'GetParameterNamesResponse';
+               };
+       
+=head2 Fault
+
+=cut
+
+push @$rules,
                'Fault' => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        $state->{Fault} = {
@@ -134,10 +119,25 @@ my $parser = XML::Rules->new(
                                FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
                        };
                        warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
-               }
-       ]
+                       $state->{_trigger} = 'Fault';
+               };
+
+my $parser = XML::Rules->new(
+#      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 => $rules,
 );
 
+=head1 METHODS
+
 =head2 parse
 
   my $state = CWMP::Request->parse( "<soap>request</soap>" );
@@ -151,7 +151,44 @@ sub parse {
 
        $state = {};
        $parser->parsestring( $xml );
+       if ( my $trigger = $state->{_trigger} ) {
+               warn "### call_trigger( $trigger )\n";
+               $self->call_trigger( $trigger, $state );
+       }
+       # XXX don't propagate _trigger (useful?)
+       delete( $state->{_trigger} );
        return $state;
 }
 
+=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>).
+
+  _tag( $tag_hash, $name, $sub_key )
+
+=cut
+
+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;
+       }
+}
+
 1;