From 5d739fbf3bb8900d1e6bd08289632bdf15f98f97 Mon Sep 17 00:00:00 2001
From: Dobrica Pavlinusic <dpavlin@rot13.org>
Date: Wed, 14 Nov 2007 19:23:32 +0000
Subject: [PATCH]  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
---
 Makefile.PL         |  1 +
 lib/CWMP/Request.pm | 13 +++++++++++++
 t/10-request.t      | 23 +++++++++++++++++++++--
 3 files changed, 35 insertions(+), 2 deletions(-)

diff --git a/Makefile.PL b/Makefile.PL
index 0ae4cb7..d1efc69 100644
--- 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
--- 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
--- 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;
+
-- 
2.20.1