File Coverage

blib/lib/Protocol/DBus/Message.pm
Criterion Covered Total %
statement 90 98 91.8
branch 29 44 65.9
condition 7 18 38.8
subroutine 19 20 95.0
pod 7 11 63.6
total 152 191 79.5


line stmt bran cond sub pod time code
1             package Protocol::DBus::Message;
2              
3 6     6   699 use strict;
  6         12  
  6         170  
4 6     6   26 use warnings;
  6         12  
  6         151  
5              
6             =encoding utf-8
7              
8             =head1 NAME
9              
10             Protocol::DBus::Message
11              
12             =head1 DESCRIPTION
13              
14             This class encapsulates a single DBus message. You generally should not
15             instantiate it directly.
16              
17             =cut
18              
19 6     6   2368 use Protocol::DBus::Marshal ();
  6         13  
  6         113  
20 6     6   2666 use Protocol::DBus::Message::Header ();
  6         30  
  6         142  
21              
22 6     6   40 use constant _PROTOCOL_VERSION => 1;
  6         12  
  6         1603  
23              
24             sub parse {
25 11     11 0 28006 my ($class, $buf_sr, $filehandles_ar) = @_;
26              
27 11 50       34 if ( my ($hdr, $hdr_len, $is_be) = Protocol::DBus::Message::Header::parse_simple($buf_sr) ) {
28              
29 11 50       42 if (length($$buf_sr) >= ($hdr_len + $hdr->[4])) {
30              
31 11         26 my $body_sig = $hdr->[6]{ Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'} };
32              
33 11 100       26 if ($hdr->[4]) {
34 8 50       22 die "No SIGNATURE header field!" if !defined $body_sig;
35             }
36              
37 11         17 my $body_data;
38              
39 11 100       25 if ($body_sig) {
40 8         24 local $Protocol::DBus::Marshal::FILEHANDLES = $filehandles_ar;
41              
42 8 50       50 ($body_data) = Protocol::DBus::Marshal->can( $is_be ? 'unmarshal_be' : 'unmarshal_le' )->($buf_sr, $hdr_len, $body_sig);
43             }
44              
45 11         55 my %self = ( _body_sig => $body_sig );
46 11         26 @self{'_type', '_flags', '_serial', '_hfields', '_body'} = (@{$hdr}[1, 2, 5, 6], $body_data);
  11         56  
47              
48             # Remove the unmarshaled bytes.
49 11         39 substr( $$buf_sr, 0, $hdr_len + $hdr->[4], q<> );
50              
51 11         67 return bless \%self, $class;
52             }
53             }
54              
55 0         0 return undef;
56             }
57              
58 6     6   43 use constant _REQUIRED => ('type', 'serial', 'hfields');
  6         13  
  6         5432  
59              
60             sub new {
61 5     5 0 1228 my ($class, %opts) = @_;
62              
63 5         52 my @missing = grep { !defined $opts{$_} } _REQUIRED();
  15         54  
64 5 50       23 die "missing: @missing" if @missing;
65              
66 5   50     22 $opts{'type'} = Protocol::DBus::Message::Header::MESSAGE_TYPE()->{ $opts{'type'} } || die "Bad “type”: '$opts{'type'}'";
67              
68 5         23 my $flags = 0;
69 5 50       26 if ($opts{'flags'}) {
70 0         0 for my $f (@{ $opts{'flags'} }) {
  0         0  
71 0   0     0 $flags |= Protocol::DBus::Message::Header::FLAG()->{$f} || die "Bad “flag”: $f";
72             }
73             }
74              
75 5         12 $opts{'flags'} = $flags;
76              
77 5         8 my %hfields;
78              
79 5 50       14 if ($opts{'hfields'}) {
80 5         8 my $field_num;
81              
82 5         10 my $fi = 0;
83 5         11 while ( $fi < @{ $opts{'hfields'} } ) {
  28         68  
84 23         33 my ($name, $value) = @{ $opts{'hfields'} }[ $fi, 1 + $fi ];
  23         48  
85 23         36 $fi += 2;
86              
87 23   33     65 $field_num = Protocol::DBus::Message::Header::FIELD()->{$name} || do {
88             die "Bad “hfields” name: “$name”";
89             };
90              
91             $hfields{ $field_num } = [
92 23         131 Protocol::DBus::Message::Header::FIELD_SIGNATURE()->{$name},
93             $value,
94             ];
95              
96 23 100       68 if ($field_num == Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'}) {
97 3         7 $opts{'body_sig'} = $value;
98             }
99             }
100             }
101              
102 5         48 $opts{'hfields'} = bless \%hfields, 'Protocol::DBus::Type::Dict';
103              
104 5 100       30 if ($opts{'body'}) {
    50          
105 3 50       10 die "“body” requires a SIGNATURE header!" if !$opts{'body_sig'};
106             }
107             elsif ($opts{'body_sig'}) {
108 0         0 die "SIGNATURE header given without “body”!";
109             }
110             else {
111 2         12 $opts{'body'} = \q<>;
112             }
113              
114 5         20 my %self = map { ( "_$_" => $opts{$_} ) } keys %opts;
  28         87  
115              
116 5         49 return bless \%self, $class;
117             }
118              
119             #----------------------------------------------------------------------
120              
121             =head1 METHODS
122              
123             =head2 I->get_header( $NAME )
124              
125             $NAME is, e.g., C or the value of the corresponding
126             member of C.
127              
128             =cut
129              
130             sub get_header {
131 41 50   41 1 940 if ($_[1] =~ tr<0-9><>c) {
132 41   50     178 return $_[0]->{'_hfields'}{ Protocol::DBus::Message::Header::FIELD()->{$_[1]} || die("Bad header: “$_[1]”") };
133             }
134              
135 0         0 return $_[0]->{'_hfields'}{$_[1]};
136             }
137              
138             =head2 I->get_body()
139              
140             Always returned as an array reference or undef. See below about mapping
141             between D-Bus and Perl.
142              
143             =cut
144              
145             sub get_body {
146 9     9 1 205 return $_[0]->{'_body'};
147             }
148              
149             =head2 I->get_type()
150              
151             Returns a number. Cross-reference with the D-Bus specification.
152              
153             =cut
154              
155             sub get_type {
156 5     5 1 2178 return $_[0]->{'_type'};
157             }
158              
159             =head2 I->type_is( $NAME )
160              
161             Convenience method; $NAME is, e.g., C.
162              
163             =cut
164              
165             sub type_is {
166 10     10 1 14036 my ($self, $name) = @_;
167              
168 10   33     60 return $_[0]->{'_type'} == (Protocol::DBus::Message::Header::MESSAGE_TYPE()->{$name} || do {
169             my @valids = sort keys %{ Protocol::DBus::Message::Header::MESSAGE_TYPE() };
170             die "Invalid type name: $name (valids are: @valids)";
171             });
172             }
173              
174             =head2 I->get_flags()
175              
176             Returns a number. Cross-reference with the D-Bus specification.
177              
178             =cut
179              
180             sub get_flags {
181 4     4 1 101 return $_[0]->{'_flags'};
182             }
183              
184             =head2 I->flags_have( @NAME )
185              
186             Convenience method; indicates whether all of the given @NAMES
187             (e.g., C) correspond to flags that are set in the message.
188              
189             =cut
190              
191             sub flags_have {
192 2     2 1 54 my ($self, @names) = @_;
193              
194 2 50       6 die "Need flag names!" if !@names;
195              
196 2         4 for my $name (@names) {
197 2 50 33     9 return 0 if !($_[0]->{'_flags'} & (Protocol::DBus::Message::Header::FLAG()->{$name} || do {
198             my @valids = sort keys %{ Protocol::DBus::Message::Header::FLAG() };
199             die "Invalid flag name: “$name” (valids are: @valids)";
200             }));
201             }
202              
203 2         5 return 1;
204             }
205              
206             =head2 I->get_serial()
207              
208             Returns a number.
209              
210             =cut
211              
212             sub get_serial {
213 5     5 1 103 return $_[0]->{'_serial'};
214             }
215              
216             #----------------------------------------------------------------------
217              
218             our $_use_be;
219             BEGIN {
220 6     6   662 $_use_be = 0;
221             }
222              
223             sub to_string_le {
224 5     5 0 24 return _to_string(@_);
225             }
226              
227             sub to_string_be {
228 0     0 0 0 local $_use_be = 1;
229 0         0 return _to_string(@_);
230             }
231              
232             #----------------------------------------------------------------------
233              
234 6     6   44 use constant _LEADING_BYTE => map { ord } ('l', 'B');
  6         12  
  6         13  
  12         1847  
235              
236             sub _to_string {
237 5     5   12 my ($self) = @_;
238              
239 5         9 my ($body_m_sr, $fds_ar);
240              
241 5 100       28 if ($self->{'_body_sig'}) {
242             ($body_m_sr, $fds_ar) = Protocol::DBus::Marshal->can( $_use_be ? 'marshal_be' : 'marshal_le' )->(
243             $self->{'_body_sig'},
244 3 50       26 $self->{'_body'},
245             );
246             }
247              
248             local $self->{'_hfields'}{ Protocol::DBus::Message::Header::FIELD()->{'UNIX_FDS'} } = [
249 5 50 66     40 Protocol::DBus::Message::Header::FIELD_SIGNATURE()->{'UNIX_FDS'},
250             0 + @$fds_ar,
251             ] if $fds_ar && @$fds_ar;
252              
253             my $data = [
254             (_LEADING_BYTE())[ $_use_be ],
255             $self->{'_type'},
256             $self->{'_flags'},
257             _PROTOCOL_VERSION(),
258             $body_m_sr ? length( $$body_m_sr ) : 0,
259             $self->{'_serial'},
260 5 100       30 $self->{'_hfields'},
261             ];
262              
263 5 50       131 my ($buf_sr) = Protocol::DBus::Marshal->can( $_use_be ? 'marshal_be' : 'marshal_le' )->(
264             Protocol::DBus::Message::Header::SIGNATURE(),
265             $data,
266             );
267              
268 5         22 Protocol::DBus::Pack::align_str($$buf_sr, 8);
269              
270 5 100       15 $$buf_sr .= $$body_m_sr if $body_m_sr;
271              
272 5         21 return( $buf_sr, $fds_ar );
273             }
274              
275             #----------------------------------------------------------------------
276              
277             =head1 MAPPING D-BUS TO PERL
278              
279             =over
280              
281             =item * Numeric and string types are represented as plain Perl scalars.
282              
283             =item * UNIX_FDs are normally represented as Perl filehandle objects.
284             If Protocol::DBus receives a UNIX_FD that doesn’t correspond to a received
285             file descriptor, the UNIX_FD will be represented as the number passed in
286             the raw D-Bus message, and a warning is thrown.
287              
288             =item * By default, variant signatures are discarded, and the values are
289             given by themselves. See L’s
290             C if you need an alternative mapping
291             method that preserves the signatures.
292              
293             =item * Other containers are represented as blessed references:
294             C, C, and
295             C. Currently these are just plain hash and
296             array references that are bless()ed; i.e., the classes themselves have no
297             methods defined (and aren’t even defined Perl namespaces).
298              
299             =back
300              
301             =head1 MAPPING PERL TO D-BUS
302              
303             =over
304              
305             =item * Use plain Perl scalars to represent all numeric and string types.
306              
307             =item * Use plain Perl filehandle objects to represent UNIX_FDs.
308              
309             =item * Use array references to represent D-Bus arrays and structs.
310             Use hash references for dicts.
311              
312             =item * Use a two-member array reference—signature then value—to represent
313             a D-Bus variant. (Note the inconsistency with the reverse mapping.)
314              
315             =back
316              
317             =head2 Examples
318              
319             =over
320              
321             =item * C - C<( $s0, [ $s1 ] )>
322              
323             =item * C - C<( \@ss )>
324              
325             =item * C - C<( \%ss )>
326              
327             =back
328              
329             =cut
330              
331             1;