File Coverage

blib/lib/Net/IMP/Remote/Server.pm
Criterion Covered Total %
statement 21 72 29.1
branch 0 16 0.0
condition 0 2 0.0
subroutine 7 17 41.1
pod 0 8 0.0
total 28 115 24.3


line stmt bran cond sub pod time code
1 1     1   2957 use strict;
  1         3  
  1         49  
2 1     1   6 use warnings;
  1         2  
  1         42  
3              
4             package Net::IMP::Remote::Server;
5 1     1   5 use Net::IMP;
  1         2  
  1         108  
6 1     1   7 use Net::IMP::Remote::Protocol;
  1         1  
  1         88  
7 1     1   5 use Scalar::Util 'weaken';
  1         1  
  1         41  
8 1     1   5 use Net::IMP::Debug;
  1         2  
  1         15  
9 1     1   116 use Carp;
  1         2  
  1         991  
10              
11             sub new {
12 0     0 0   my ($class,$conn,$factory,%args) = @_;
13 0           my $self = bless {
14             conn => $conn,
15             factory => $factory,
16             }, $class;
17              
18 0           weaken( my $wself = $self );
19 0           $conn->nextop({
20             IMPRPC_EXCEPTION+0 => [ \&exception, $wself ],
21             IMPRPC_GET_INTERFACE+0 => [ \&get_interface, $wself ],
22             IMPRPC_SET_INTERFACE+0 => [ \&set_interface, $wself ],
23             IMPRPC_NEW_ANALYZER+0 => [ \&new_analyzer, $wself ],
24             IMPRPC_DEL_ANALYZER+0 => [ \&del_analyzer, $wself ],
25             IMPRPC_DATA+0 => [ \&data, $wself ],
26             }, -1);
27 0           return $self;
28             }
29              
30             sub get_interface {
31 0     0 0   my ($self,@if) = @_;
32 0           @if = $self->{factory}->get_interface(@if);
33 0           $self->{conn}->rpc([ IMPRPC_INTERFACE, @if ]);
34 0           return;
35             }
36              
37             sub set_interface {
38 0     0 0   my ($self,$if) = @_;
39 0           my $newf = $self->{factory}->set_interface($if);
40 0 0         if ( ! $newf ) {
41 0           $self->{conn}->rpc([
42             IMPRPC_EXCEPTION,0,
43             "set_interface: unsupported interface"
44             ]);
45 0           return;
46             } else {
47 0           $self->{factory} = $newf;
48             }
49             }
50              
51             sub new_analyzer {
52 0     0 0   my ($self,$id,$ctx) = @_;
53 0           my $conn = $self->{conn};
54 0 0         if ( $conn->get_analyzer($id) ) {
55 0           $conn->rpc([IMPRPC_EXCEPTION,$id,"analyzer exists already"]);
56 0           return;
57             }
58              
59 0           my $obj = $self->{factory}->new_analyzer(%$ctx);
60 0 0         if ( ! $obj ) {
61 0           debug("analyzer $id not wanted - using dummy");
62 0           $conn->add_analyzer('dummy',$id);
63 0           $conn->rpc([IMPRPC_RESULT,$id,IMP_PASS,0,IMP_MAXOFFSET]);
64 0           $conn->rpc([IMPRPC_RESULT,$id,IMP_PASS,1,IMP_MAXOFFSET]);
65 0           return;
66             } else {
67 0           debug("created analyzer $id - $obj");
68 0           $conn->add_analyzer($obj,$id);
69 0           weaken( my $wconn = $conn );
70             $obj->set_callback(sub {
71 0     0     $wconn->rpc([IMPRPC_RESULT,$id,@$_]) for (@_);
72 0           });
73             }
74             }
75              
76             sub del_analyzer {
77 0     0 0   my ($self,$id) = @_;
78 0           $self->{conn}->del_analyzer($id);
79             }
80              
81             sub data {
82 0     0 0   my ($self,$id,$dir,$offset,$type,$data) = @_;
83 0 0         my $obj = $self->{conn}->get_analyzer($id) or do {
84 0           debug("no analyzer $id");
85 0           $self->{conn}->rpc([IMPRPC_EXCEPTION,$id,"no analyzer $id"]);
86 0           return;
87             };
88 0   0       debug("got data($dir,%s,$type,datalen=%d)",$offset//"",length($data));
89 0 0         ref($obj) or return; # dummy
90 0           $obj->data($dir,$data,$offset,$type);
91             }
92              
93             sub exception {
94 0     0 0   my ($self,$id,$msg) = @_;
95 0 0         if ( $id ) {
96 0           warn "[$id] $msg\n";
97             } else {
98 0           warn "[*] $msg\n";
99             }
100             }
101              
102             sub close {
103 0     0 0   my $self = shift;
104 0 0         my $id = $self->{id} or return;
105 0 0         my $conn = $self->{conn} or return;
106 0           $conn->del_analyzer($id);
107             }
108              
109 0     0     sub DESTROY { goto &close }
110              
111             1;
112             __END__