From: Dobrica Pavlinusic <dpavlin@rot13.org>
Date: Wed, 14 Nov 2007 18:16:14 +0000 (+0000)
Subject:  r210@brr:  dpavlin | 2007-11-14 19:15:41 +0100
X-Git-Url: http://git.rot13.org/?p=perl-cwmp.git;a=commitdiff_plain;h=6ae55ee7caaa8c33a10a983dcc3b50928eb52914

 r210@brr:  dpavlin | 2007-11-14 19:15:41 +0100
 New version [0.09] with buch of changes:
 - command queue for device now really works
 - cpe-queue.pl now supports --list to display queue
 - convert all methods to receive just one param (simplifies code all over)


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

diff --git a/Makefile.PL b/Makefile.PL
index 9896774..0ae4cb7 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -3,7 +3,7 @@ use lib './lib';
 use inc::Module::Install;
 
 name		'CWMP';
-version		'0.08';
+version		'0.09';
 license		'GPL';
 requires	'Net::Server';
 requires	'HTTP::Daemon';
diff --git a/bin/cpe-queue.pl b/bin/cpe-queue.pl
index 2135884..c9f9c21 100755
--- a/bin/cpe-queue.pl
+++ b/bin/cpe-queue.pl
@@ -9,13 +9,16 @@ use strict;
 use lib './lib';
 use CWMP::Queue;
 use Getopt::Long;
+use File::Slurp;
 
-my $debug = 0;
-my $protocol_dump = 1;
+my $debug = 1;
+my $protocol_dump = 0;
+my $list = 0;
 
 GetOptions(
 	'debug+' => \$debug,
 	'protocol-dump!' => \$protocol_dump,
+	'list!' => \$list,
 );
 
 my $id = shift @ARGV || die "usage: $0 CPE_id [--protocol-dump]\n";
@@ -27,6 +30,7 @@ die "ID isn't valid: $id\n" unless $id =~ m/^\w+$/;
 
 my $q = CWMP::Queue->new({ id => $id, debug => $debug });
 
+
 if ( $protocol_dump ) {
 
 	warn "generating dump of xml protocol with CPE\n";
@@ -34,20 +38,88 @@ if ( $protocol_dump ) {
 	$q->enqueue( 'GetRPCMethods' );
 	$q->enqueue( 'GetParameterNames' );
 
-#	$q->enqueue( 'GetParameterNames', 'InternetGatewayDevice.DeviceInfo.SerialNumber', 0 );
-#	$q->enqueue( 'GetParameterNames', 'InternetGatewayDevice.DeviceInfo.', 1 );
+	$q->enqueue( 'GetParameterNames', [ 'InternetGatewayDevice.DeviceInfo.SerialNumber', 0 ] );
+	$q->enqueue( 'GetParameterNames', [ 'InternetGatewayDevice.DeviceInfo.', 1 ] );
 
-	$q->enqueue( 'GetParameterValues',
-				'InternetGatewayDevice.DeviceInfo.SerialNumber',
-				'InternetGatewayDevice.DeviceInfo.VendorConfigFile.',
-				'InternetGatewayDevice.DeviceInfo.X_000E50_Country',
-	);
-	$q->enqueue( 'SetParameterValues',
-				'InternetGatewayDevice.DeviceInfo.ProvisioningCode' => 'test provision',
-#			'InternetGatewayDevice.DeviceInfo.X_000E50_Country' => 1,
-	);
+	$q->enqueue( 'GetParameterValues', [
+		'InternetGatewayDevice.DeviceInfo.SerialNumber',
+		'InternetGatewayDevice.DeviceInfo.VendorConfigFile.',
+		'InternetGatewayDevice.DeviceInfo.X_000E50_Country',
+	] );
+	$q->enqueue( 'SetParameterValues', {
+		'InternetGatewayDevice.DeviceInfo.ProvisioningCode' => 'test provision',
+#		'InternetGatewayDevice.DeviceInfo.X_000E50_Country' => 1,
+	});
 
 #	$q->enqueue( 'Reboot' );
 
 }
 
+if ( $list ) {
+
+	warn "list all jobs for $id\n";
+
+	my @active = ();
+	my @queued = ();
+	my $hostname = $q->dq->gethostname();
+
+	sub wanted {
+	  my ($visitcontext, $job) = @_;
+
+	  my $data = $job->get_data_path();
+	  my $nbytes = $job->get_data_size_bytes();
+	  my $timet = $job->get_time_submitted_secs();
+	  my $hname = $job->get_hostname_submitted();
+	  my $jobid = $job->{jobid};
+
+	  my $text = sprintf (
+				"%s (%d bytes)\n  Submitted: %s on %s\n",
+				$jobid, $nbytes, scalar localtime $timet, $hname);
+
+		$text .= read_file( $data ) || die "can't open $data: $!";
+
+	  if ($job->{active_pid})
+	  {
+		if ($hostname eq $job->{active_host}
+			&& !kill (0, $job->{active_pid}))
+		{
+		  $text = sprintf (
+				"(dead lockfile)\n  %s",
+				$text);
+		}
+		else {
+		  $text = sprintf (
+				"(pid: %d\@%s)\n  %s",
+				$job->{active_pid}, $job->{active_host}, $text);
+		}
+
+		push (@active, $text);
+	  }
+	  else {
+		push (@queued, $text);
+	  }
+
+	  $job->finish();
+	}
+
+	$q->dq->visit_all_jobs(\&wanted, undef);
+	printf "Jobs: active: %d  queued: %d\n",
+			scalar @active, scalar @queued;
+	
+	print "Active jobs [", scalar @active, "]\n",join("\n\n", @active) if @active;
+	print "Queued jobs [", scalar @queued, "]\n",join("\n\n", @queued) if @queued;
+
+} else {
+
+	warn "injecting some tests commands\n";
+
+	$q->enqueue( 'SetParameterValues', {
+		'InternetGatewayDevice.DeviceInfo.ProvisioningCode' => 'test provision',
+#		'InternetGatewayDevice.DeviceInfo.X_000E50_Country' => 1,
+	});
+
+	$q->enqueue( 'GetParameterValues', [
+		'InternetGatewayDevice.DeviceInfo.ProvisioningCode',
+	]);
+
+}
diff --git a/lib/CWMP/Methods.pm b/lib/CWMP/Methods.pm
index ab77c99..e8eb113 100644
--- a/lib/CWMP/Methods.pm
+++ b/lib/CWMP/Methods.pm
@@ -84,11 +84,11 @@ sub GetRPCMethods {
 
 =head2 SetParameterValues
 
-  $method->SetParameterValues( $state,
+  $method->SetParameterValues( $state, {
 	param1 => 'value1',
 	param2 => 'value2',
 	...
-  );
+  });
 
 It doesn't support base64 encoding of values yet.
 
@@ -103,18 +103,9 @@ sub SetParameterValues {
 
 	confess "SetParameterValues needs parameters" unless @_;
 
-	my @params = @_;
+	my $params = shift || return;
 
-	my ( @names, @values );
-
-	while ( @_ ) {
-		push @names, shift @_;
-		push @values, shift @_;
-	}
-
-	confess "can't convert params ", dump( @params ), " to name/value pairs" unless $#names == $#values;
-
-	warn "# SetParameterValues", dump( @params ), "\n" if $self->debug;
+	warn "# SetParameterValues = ", dump( $params ), "\n" if $self->debug;
 
 	$self->xml( $state, sub {
 		my ( $X, $state ) = @_;
@@ -125,9 +116,9 @@ sub SetParameterValues {
 					map {
 						$X->ParameterValueStruct( $cwmp,
 							$X->Name( $cwmp, $_ ),
-							$X->Value( $cwmp, shift @values )
+							$X->Value( $cwmp, $params->{$_} )
 						)
-					} @names
+					} sort keys %$params
 				)
 			)
 		);
@@ -137,14 +128,20 @@ sub SetParameterValues {
 
 =head2 GetParameterValues
 
-  $method->GetParameterValues( $state, $ParameterNames );
+  $method->GetParameterValues( $state, [ 'ParameterName', ... ] );
 
 =cut
 
+sub _array_param {
+	my $v = shift;
+	confess "array_mandatory(",dump($v),") isn't ARRAY" unless ref($v) eq 'ARRAY';
+	return @$v;
+}
+
 sub GetParameterValues {
 	my $self = shift;
 	my $state = shift;
-	my @ParameterNames = @_;
+	my @ParameterNames = _array_param(shift);
 	confess "GetParameterValues need ParameterNames" unless @ParameterNames;
 	warn "# GetParameterValues", dump( @ParameterNames ), "\n" if $self->debug;
 
@@ -163,14 +160,16 @@ sub GetParameterValues {
 
 =head2 GetParameterNames
 
-  $method->GetParameterNames( $state, $ParameterPath, $NextLevel );
+  $method->GetParameterNames( $state, [ $ParameterPath, $NextLevel ] );
 
 =cut
 
 sub GetParameterNames {
-	my ( $self, $state, $ParameterPath, $NextLevel ) = @_;
-	$ParameterPath ||= '';	# all
-	$NextLevel ||= 0;		# all
+	my ( $self, $state, $param ) = @_;
+	# default: all, all
+	my ( $ParameterPath, $NextLevel ) = _array_param( $param );
+	$ParameterPath ||= '';
+	$NextLevel ||= 0;
 	warn "# GetParameterNames( '$ParameterPath', $NextLevel )\n" if $self->debug;
 	$self->xml( $state, sub {
 		my ( $X, $state ) = @_;
diff --git a/lib/CWMP/Queue.pm b/lib/CWMP/Queue.pm
index bf4595e..8087255 100644
--- a/lib/CWMP/Queue.pm
+++ b/lib/CWMP/Queue.pm
@@ -66,7 +66,9 @@ sub new {
 =head2 enqueue
 
   $q->enqueue(
-  	'foo.bar.baz' => 42,
+  	'CommandToDispatch', {
+  		'foo.bar.baz' => 42,
+	}
   );
 
 =cut
@@ -75,16 +77,17 @@ sub enqueue {
 	my $self = shift;
 
 	my $id = $self->id;
+	my ( $dispatch, $args ) = @_;
+
+	warn "## enqueue( $dispatch with ", dump( $args ), " ) for $id\n" if $self->debug;
 	
-	warn "## enqueue( $id, ", dump( @_ ), " )\n" if $self->debug;
-	
-	$self->{dq}->{$id}->enqueue_string( Dump( @_ ) );
+	$self->{dq}->{$id}->enqueue_string( Dump({ dispatch => $dispatch, args => $args }) );
 }
 
 =head2 dequeue
 
   my $job = $q->dequeue;
-  my $dispatch = $job->dispatch;
+  my ( $dispatch, $args ) = $job->dispatch;
   # after dispatch is processed
   $job->finish;
 
@@ -98,26 +101,63 @@ sub dequeue {
 	my $job = $self->{dq}->{$id}->pickup_queued_job();
 	return unless defined $job;
 
-	warn "## dequeue( $id ) = ", dump( $job ), " )\n" if $self->debug;
+	warn "## dequeue for $id = ", dump( $job ), " )\n" if $self->debug;
+
+	return CWMP::Queue::Job->new({ job => $job, debug => $self->debug });
+}
+
+=head2 dq
+
+Accessor to C<IPC::DirQueue> object
 
-	return CWMP::Queue::Job->new({ job => $job });
+  my $dq = $q->dq;
+
+=cut
+
+sub dq {
+	my $self = shift;
+	return $self->{dq}->{$self->id};
 }
 
 package CWMP::Queue::Job;
 
+=head1 CWMP::Queue::Job
+
+Single queued job
+
+=cut
+
 use base qw/Class::Accessor/;
 __PACKAGE__->mk_accessors( qw/
 job
+debug
 / );
 
 use YAML qw/LoadFile/;
+use Data::Dump qw/dump/;
+
+=head2 dispatch
+
+  my ( $dispatch, $args ) = $job->dispatch;
+
+=cut
 
 sub dispatch {
 	my $self = shift;
 	my $path = $self->job->get_data_path || die "get_data_path?";
-	return LoadFile( $path ) || die "can't read $path: $!";
+	my $data = LoadFile( $path ) || die "can't read $path: $!";
+	warn "## dispatch returns ",dump($data),"\n" if $self->debug;
+	return ( $data->{dispatch}, $data->{args} );
 }
 
+=head2 finish
+
+Finish job and remove it from queue
+
+  $job->finish;
+
+=cut
+
 sub finish {
 	my $self = shift;
 	$self->job->finish;
diff --git a/lib/CWMP/Session.pm b/lib/CWMP/Session.pm
index cf11c30..ff6d95d 100644
--- a/lib/CWMP/Session.pm
+++ b/lib/CWMP/Session.pm
@@ -193,20 +193,16 @@ If debugging level of 3 or more, it will create dumps of responses named C<< dum
 sub dispatch {
 	my $self = shift;
 
-	my $dispatch = shift || die "no dispatch?";
-	my @args = @_;
+warn "##!!! dispatch(",dump( @_ ),")\n";
 
-	if ( ref($dispatch) eq 'ARRAY' ) {
-		my @a = @$dispatch;
-		$dispatch = shift @a;
-		push @args, @a;
-	}
+	my $dispatch = shift || die "no dispatch?";
+	my $args = shift;
 
 	my $response = CWMP::Methods->new({ debug => $self->debug });
 
 	if ( $response->can( $dispatch ) ) {
-		warn ">>> dispatching to $dispatch\n";
-		my $xml = $response->$dispatch( $self->state, @args );
+		warn ">>> dispatching to $dispatch with args ",dump( $args ),"\n";
+		my $xml = $response->$dispatch( $self->state, $args );
 		warn "## response payload: ",length($xml)," bytes\n$xml\n" if $self->debug;
 		if ( $self->debug > 2 ) {
 			my $file = sprintf("dump/%04d-%s.response", $dump_nr++, $self->sock->peerhost);
diff --git a/t/06-queue.t b/t/06-queue.t
index e56b93e..8cdc92b 100755
--- a/t/06-queue.t
+++ b/t/06-queue.t
@@ -4,7 +4,7 @@ use warnings;
 
 my $debug = shift @ARGV;
 
-use Test::More tests => 213;
+use Test::More tests => 255;
 use Data::Dump qw/dump/;
 use lib 'lib';
 
@@ -23,18 +23,23 @@ ok( my $obj = CWMP::Queue->new({
 isa_ok( $obj, 'CWMP::Queue' );
 
 for my $i ( 1 .. 42 ) {
-	ok( $obj->enqueue({
-		i => $i,
-		foo => 'bar',
-	}), "enqueue $i" );
+	ok( $obj->enqueue(
+		"command-$i",
+		{
+			i => $i,
+			foo => 'bar',
+		}
+	), "enqueue $i" );
 };
 
 my $i = 1;
 
 while ( my $job = $obj->dequeue ) {
 	ok( $job, "dequeue $i" );
-	ok( my $dispatch = $job->dispatch, "dispatch $i" );
-	cmp_ok( $dispatch->{i}, '==', $i, "i == $i" );
+	ok( my ( $dispatch, $args ) = $job->dispatch, "job->dispatch $i" );
+	cmp_ok( $dispatch, 'eq', "command-$i", "dispatch $i" );
+	diag "args = ",dump( $args ) if $debug;
+	cmp_ok( $args->{i}, '==', $i, "args i == $i" );
 	ok( $job->finish, "finish $i" );
 	$i++;
 }
diff --git a/t/20-methods.t b/t/20-methods.t
index f81805c..9d260c3 100755
--- a/t/20-methods.t
+++ b/t/20-methods.t
@@ -28,7 +28,7 @@ sub check_method {
 	};
 
 	diag "check_method $command",dump( 'state', @_ ) if $debug;
-	ok( my $xml = $method->$command( $state, @_ ), "generate method $command" . dump(@_) );
+	ok( my $xml = $method->$command( $state, shift ), "generate method $command" . dump(@_) );
 
 	my $file = "$abs_path/methods/$command.xml";
 
@@ -45,12 +45,12 @@ sub check_method {
 check_method( 'InformResponse' );
 check_method( 'GetRPCMethods' );
 check_method( 'Reboot' );
-check_method( 'SetParameterValues',
+check_method( 'SetParameterValues', {
 	'InternetGatewayDevice.DeviceInfo.ProvisioningCode' => 'test provision',
 	'InternetGatewayDevice.DeviceInfo.X_000E50_Country' => 42,
-);
-check_method( 'GetParameterNames', 'InternetGatewayDevice.DeviceInfo.SerialNumber' );
-check_method( 'GetParameterValues',
+});
+check_method( 'GetParameterNames', [ 'InternetGatewayDevice.DeviceInfo.SerialNumber' ] );
+check_method( 'GetParameterValues', [
 	'InternetGatewayDevice.DeviceInfo.SerialNumber',
 	'InternetGatewayDevice.DeviceInfo.VendorConfigFile.',
-);
+]);