File Coverage

blib/lib/Protocol/DBus/Parser.pm
Criterion Covered Total %
statement 54 74 72.9
branch 16 44 36.3
condition 2 14 14.2
subroutine 9 10 90.0
pod 0 3 0.0
total 81 145 55.8


line stmt bran cond sub pod time code
1             package Protocol::DBus::Parser;
2              
3 5     5   35 use strict;
  5         7  
  5         150  
4 5     5   46 use warnings;
  5         10  
  5         114  
5              
6 5     5   26 use Protocol::DBus::Marshal ();
  5         8  
  5         57  
7 5     5   29 use Protocol::DBus::Message ();
  5         10  
  5         223  
8              
9 5     5   29 use constant SINGLE_UNIX_FD_CMSGHDR => (0, 0, pack 'I!');
  5         14  
  5         336  
10              
11 5     5   26 use constant _LE_INIT_UNPACK => 'x4 V x4 V';
  5         10  
  5         311  
12 5     5   30 use constant _BE_INIT_UNPACK => 'x4 N x4 N';
  5         10  
  5         4100  
13              
14             sub new {
15 2     2 0 18 my ($class, $socket) = @_;
16              
17 2         68 return bless { _s => $socket, _buf => q<> }, $class;
18             }
19              
20             sub get_message {
21 3     3 0 8 my ($self) = @_;
22              
23 3         15 my $msg;
24              
25 3 50       43 if (!$self->{'_bodysz'}) {
26 3 50 0     15235 if (defined recv( $self->{'_s'}, my $peek, 16, Socket::MSG_PEEK() )) {
    0          
27 3 50       26 if ( 16 == length $peek ) {
28 3 50       34 @{$self}{'_bodysz', '_hdrsz'} = unpack(
  3         50  
29             (0 == index($peek, 'B')) ? _BE_INIT_UNPACK() : _LE_INIT_UNPACK(),
30             $peek,
31             );
32              
33 3         47 Protocol::DBus::Pack::align( $self->{'_hdrsz'}, 8 );
34              
35 3         29 $self->{'_msgsz'} = 16 + $self->{'_hdrsz'} + $self->{'_bodysz'};
36             }
37             }
38             elsif (!$!{'EAGAIN'} && !$!{'EWOULDBLOCK'}) {
39 0         0 die "recv(): $!";
40             }
41             }
42              
43 3 50 33     69 if (defined $self->{'_bodysz'} && !defined $self->{'_unix_fds'}) {
44 3 50 0     52 if (defined recv( $self->{'_s'}, my $full_hdr, 16 + $self->{'_hdrsz'}, Socket::MSG_PEEK() )) {
    0          
45 3 50       15 if ( length($full_hdr) == 16 + $self->{'_hdrsz'} ) {
46 3         29 my ($hdr) = Protocol::DBus::Message::Header::parse_simple(\$full_hdr);
47              
48 3   50     36 $self->{'_unix_fds'} = $hdr->[6]{ Protocol::DBus::Message::Header::FIELD()->{'UNIX_FDS'} } || 0;
49              
50 3         10 $self->{'_pending_unix_fds'} = $self->{'_unix_fds'};
51              
52 3         9 my $body_sig = $hdr->[6]{ Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'} };
53              
54 3 100       24 if ($hdr->[4]) {
55 2 50       17 die "No SIGNATURE header field!" if !defined $body_sig;
56             }
57             }
58             }
59             elsif (!$!{'EAGAIN'} && !$!{'EWOULDBLOCK'}) {
60 0         0 die "recv(): $!";
61             }
62             }
63              
64 3 50       107 if (defined $self->{'_unix_fds'}) {
65              
66 3         9 my $needed_bytes = $self->{'_msgsz'} - length $self->{'_buf'};
67              
68 3         37 my $got;
69              
70 3 50       11 if ($self->{'_unix_fds'}) {
71 0         0 my $msg = Socket::MsgHdr->new(
72             buflen => $needed_bytes,
73             );
74              
75             # The unix FDs might arrive in a single control
76             # message, as individual control messages, or as
77             # some combination thereof. There is no way to know.
78             # So plan for the worst, and assume each unix FD is
79             # in its own control.
80 0         0 $msg->cmsghdr( (SINGLE_UNIX_FD_CMSGHDR()) x $self->{'_pending_unix_fds'} );
81              
82 0         0 $got = Socket::MsgHdr::recvmsg( $self->{'_s'}, $msg );
83 0 0       0 if (defined $got) {
84              
85 0 0       0 if ($self->{'_pending_unix_fds'}) {
86 0         0 require Protocol::DBus::Parser::UnixFDs;
87 0         0 push @{ $self->{'_filehandles'} }, Protocol::DBus::Parser::UnixFDs::extract_from_msghdr($msg);
  0         0  
88 0         0 $self->{'_pending_unix_fds'} = $self->{'_unix_fds'} - @{ $self->{'_filehandles'} };
  0         0  
89             }
90              
91 0         0 $self->{'_buf'} .= $msg->buf();
92             }
93             }
94             else {
95             $got = sysread(
96             $self->{'_s'},
97             $self->{'_buf'},
98             $needed_bytes,
99 3         72 length $self->{'_buf'},
100             );
101             }
102              
103 3 50 0     17 if (defined $got) {
    0          
104 3 50       11 if ($got >= $needed_bytes) {
    0          
105 3 50       16 local $Protocol::DBus::Marshal::PRESERVE_VARIANT_SIGNATURES = 1 if $self->{'_preserve_variant_signatures'};
106              
107             # This clears out the buffer .. it should??
108 3         44 my $msg = Protocol::DBus::Message->parse( \$self->{'_buf'}, delete $self->{'_filehandles'} );
109              
110 3 50       14 die "Not enough bytes??" if !$msg;
111              
112 3         6 delete @{$self}{'_bodysz', '_unix_fds'};
  3         11  
113              
114 3         19 return $msg;
115             }
116             elsif (!$got) {
117 0           die "Peer stopped writing!";
118             }
119             }
120             elsif (!$!{'EAGAIN'} && !$!{'EWOULDBLOCK'}) {
121 0           die "recv(): $!";
122             }
123             }
124              
125 0           return undef;
126             }
127              
128             sub preserve_variant_signatures {
129 0     0 0   my $self = shift;
130              
131 0 0         if (@_) {
132 0           $self->{'_preserve_variant_signatures'} = !!$_[0];
133             }
134              
135 0           return !!$self->{'_preserve_variant_signatures'};
136             }
137              
138             1;