File Coverage

blib/lib/Protocol/DBus/Parser.pm
Criterion Covered Total %
statement 57 78 73.0
branch 17 46 36.9
condition 2 14 14.2
subroutine 10 11 90.9
pod 0 3 0.0
total 86 152 56.5


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