use inc::Module::Install;
name 'CWMP';
-version '0.08';
+version '0.09';
license 'GPL';
requires 'Net::Server';
requires 'HTTP::Daemon';
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";
my $q = CWMP::Queue->new({ id => $id, debug => $debug });
+
if ( $protocol_dump ) {
warn "generating dump of xml protocol with CPE\n";
$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',
+ ]);
+
+}
=head2 SetParameterValues
- $method->SetParameterValues( $state,
+ $method->SetParameterValues( $state, {
param1 => 'value1',
param2 => 'value2',
...
- );
+ });
It doesn't support base64 encoding of values yet.
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 ) = @_;
map {
$X->ParameterValueStruct( $cwmp,
$X->Name( $cwmp, $_ ),
- $X->Value( $cwmp, shift @values )
+ $X->Value( $cwmp, $params->{$_} )
)
- } @names
+ } sort keys %$params
)
)
);
=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;
=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 ) = @_;
=head2 enqueue
$q->enqueue(
- 'foo.bar.baz' => 42,
+ 'CommandToDispatch', {
+ 'foo.bar.baz' => 42,
+ }
);
=cut
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;
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;
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);
my $debug = shift @ARGV;
-use Test::More tests => 213;
+use Test::More tests => 255;
use Data::Dump qw/dump/;
use lib 'lib';
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++;
}
};
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";
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.',
-);
+]);