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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (executable)
--- 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.',
-);
+]);