r212@brr: dpavlin | 2007-11-14 20:23:06 +0100

 added Class::Trigger based triggers on SOAP requests from CPE

git-svn-id: https://perl-cwmp.googlecode.com/svn/trunk@199 836a5e1a-633d-0410-964b-294494ad4392

diff --git a/Makefile.PL b/Makefile.PL
index 0ae4cb7..d1efc69 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -24,6 +24,7 @@ requires      'Hash::Merge';
 requires       'IPC::DirQueue';
 requires       'File::Spec';
 requires       'File::Path';
+requires       'Class::Trigger';
 
 build_requires 'Test::More';
 

diff --git a/lib/CWMP/Request.pm b/lib/CWMP/Request.pm
index 2456e55..1646cc1 100644 (file)
--- a/lib/CWMP/Request.pm
+++ b/lib/CWMP/Request.pm
@@ -7,6 +7,7 @@ use XML::Rules;
 use CWMP::Tree;
 use Data::Dump qw/dump/;
 use Carp qw/confess cluck/;
+use Class::Trigger;
 
 =head1 NAME
 
@@ -14,6 +15,8 @@ CWMP::Request - parse SOAP request metods
 
 =head1 CPE metods
 
+All methods described below call triggers with same name
+
 =cut
 
 my $tree = CWMP::Tree->new({ debug => 0 });
@@ -66,6 +69,7 @@ Generate InformResponse to CPE
 push @$rules,
        'Inform' => sub {
                $state->{_dispatch} = 'InformResponse';         # what reponse to call
+               $state->{_trigger} = 'Inform';
        };
 
 =head2 GetRPCMethodsResponse
@@ -77,6 +81,7 @@ push @$rules,
                'MethodList' => sub {
                        my ($tag_name, $tag_hash, $context, $parent_data) = @_;
                        $state->{MethodList} = _tag( $tag_hash, 'string' );
+                       $state->{_trigger} = 'GetRPCMethodsResponse';
                };
 
 =head2 GetParameterNamesResponse
@@ -97,6 +102,8 @@ push @$rules,
                        confess "can't eval $s : $@" if ($@);
 
                        #warn "## state = dump( $state ), "\n";
+
+                       $state->{_trigger} = 'GetParameterNamesResponse';
                };
        
 =head2 Fault
@@ -111,6 +118,7 @@ push @$rules,
                                FaultString => _tag( $tag_hash, 'FaultString', '_content' ),
                        };
                        warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n";
+                       $state->{_trigger} = 'Fault';
                };
 
 my $parser = XML::Rules->new(
@@ -142,6 +150,11 @@ sub parse {
 
        $state = {};
        $parser->parsestring( $xml );
+       if ( my $trigger = $state->{_trigger} ) {
+               __PACKAGE__->call_trigger( $trigger, $state );
+       }
+       # XXX don't propagate _trigger (useful?)
+       delete( $state->{_trigger} );
        return $state;
 }
 

diff --git a/t/10-request.t b/t/10-request.t
index 80243a7..03e9098 100755 (executable)
--- a/t/10-request.t
+++ b/t/10-request.t
@@ -4,7 +4,7 @@ use warnings;
 
 my $debug = shift @ARGV;
 
-use Test::More tests => 53;
+use Test::More tests => 73;
 use Data::Dump qw/dump/;
 use Cwd qw/abs_path/;
 use File::Slurp;
@@ -21,6 +21,9 @@ ok( $#models + 1, 'got models' );
 ok(my $abs_path = abs_path($0), "abs_path");
 $abs_path =~ s!/[^/]*$!/!;     #!fix-vim
 
+my $path2method;
+my $triggers_count;
+
 sub file_is_deeply {
        my ( $path ) = @_;
 
@@ -28,6 +31,14 @@ sub file_is_deeply {
 
        diag $xml if $debug;
 
+       ok( my $trigger = $path2method->{$path}, "path2method($path)" );
+
+       CWMP::Request->add_trigger( name => $trigger, callback => sub {
+               my ( $self, $state ) = @_;
+               $triggers_count->{$trigger}++;
+               ok( $state, "called trigger $trigger" );
+       });
+
        ok( my $state = CWMP::Request->parse( $xml ), 'parse' );
 
        my $dump_path = $path;
@@ -47,7 +58,13 @@ foreach my $model ( @models ) {
 
        my $dir = "$abs_path/$model/";
        opendir(DIR, $dir) || die "can't opendir $dir: $!";
-       my @xmls = map { "$dir/$_" } grep { /\.xml$/ && -f "$dir/$_" } readdir(DIR);
+       my @xmls = map {
+               my $path = "$dir/$_";
+               my $method = $_;
+               $method =~ s/\.xml$//;
+               $path2method->{$path} = $method;
+               $path;
+       } grep { /\.xml$/ && -f "$dir/$_" } readdir(DIR);
        closedir DIR;
 
        diag "$model has ", $#xmls + 1, " xml tests";
@@ -60,3 +77,5 @@ foreach my $model ( @models ) {
        }
 }
 
+diag "triggers_count = ",dump( $triggers_count ) if $debug;
+