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 7     7   630 use strict;
  7         13  
  7         170  
4 7     7   28 use warnings;
  7         14  
  7         141  
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 7     7   2125 use Protocol::DBus::Marshal ();
  7         14  
  7         119  
20 7     7   2387 use Protocol::DBus::Message::Header ();
  7         20  
  7         137  
21              
22 7     7   39 use constant _PROTOCOL_VERSION => 1;
  7         8  
  7         1412  
23              
24             sub parse {
25 14     14 0 23062 my ($class, $buf_sr, $filehandles_ar) = @_;
26              
27 14 50       35 if ( my ($hdr, $hdr_len, $is_be) = Protocol::DBus::Message::Header::parse_simple($buf_sr) ) {
28              
29 14 50       39 if (length($$buf_sr) >= ($hdr_len + $hdr->[4])) {
30              
31 14         31 my $body_sig = $hdr->[6]{ Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'} };
32              
33 14 100       25 if ($hdr->[4]) {
34 10 50       21 die "No SIGNATURE header field!" if !defined $body_sig;
35             }
36              
37 14         16 my $body_data;
38              
39 14 100       25 if ($body_sig) {
40 10         14 local $Protocol::DBus::Marshal::FILEHANDLES = $filehandles_ar;
41              
42 10 50       42 ($body_data) = Protocol::DBus::Marshal->can( $is_be ? 'unmarshal_be' : 'unmarshal_le' )->($buf_sr, $hdr_len, $body_sig);
43             }
44              
45 14         72 my %self = ( _body_sig => $body_sig );
46 14         25 @self{'_type', '_flags', '_serial', '_hfields', '_body'} = (@{$hdr}[1, 2, 5, 6], $body_data);
  14         92  
47              
48             # Remove the unmarshaled bytes.
49 14         45 substr( $$buf_sr, 0, $hdr_len + $hdr->[4], q<> );
50              
51 14         56 return bless \%self, $class;
52             }
53             }
54              
55 0         0 return undef;
56             }
57              
58 7     7   41 use constant _REQUIRED => ('type', 'serial', 'hfields');
  7         9  
  7         5144  
59              
60             sub new {
61 8     8 0 1530 my ($class, %opts) = @_;
62              
63 8         40 my @missing = grep { !defined $opts{$_} } _REQUIRED();
  24         63  
64 8 50       22 die "missing: @missing" if @missing;
65              
66 8   50     34 $opts{'type'} = Protocol::DBus::Message::Header::MESSAGE_TYPE()->{ $opts{'type'} } || die "Bad “type”: '$opts{'type'}'";
67              
68 8         15 my $flags = 0;
69 8 50       23 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 8         12 $opts{'flags'} = $flags;
76              
77 8         14 my %hfields;
78              
79 8 50       26 if ($opts{'hfields'}) {
80 8         11 my $field_num;
81              
82 8         10 my $fi = 0;
83 8         11 while ( $fi < @{ $opts{'hfields'} } ) {
  45         86  
84 37         42 my ($name, $value) = @{ $opts{'hfields'} }[ $fi, 1 + $fi ];
  37         62  
85 37         40 $fi += 2;
86              
87 37   33     72 $field_num = Protocol::DBus::Message::Header::FIELD()->{$name} || do {
88             die "Bad “hfields” name: “$name”";
89             };
90              
91             $hfields{ $field_num } = [
92 37         158 Protocol::DBus::Message::Header::FIELD_SIGNATURE()->{$name},
93             $value,
94             ];
95              
96 37 100       77 if ($field_num == Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'}) {
97 5         11 $opts{'body_sig'} = $value;
98             }
99             }
100             }
101              
102 8         59 $opts{'hfields'} = bless \%hfields, 'Protocol::DBus::Type::Dict';
103              
104 8 100       27 if ($opts{'body'}) {
    50          
105 5 50       15 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 3         8 $opts{'body'} = \q<>;
112             }
113              
114 8         30 my %self = map { ( "_$_" => $opts{$_} ) } keys %opts;
  45         115  
115              
116 8         44 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 55 50   55 1 958 if ($_[1] =~ tr<0-9><>c) {
132 55   50     187 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 12     12 1 192 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 6     6 1 1664 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 12     12 1 20025 my ($self, $name) = @_;
167              
168 12   33     74 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 76 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 41 my ($self, @names) = @_;
193              
194 2 50       4 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         4 return 1;
204             }
205              
206             =head2 I->get_serial()
207              
208             Returns a number.
209              
210             =cut
211              
212             sub get_serial {
213 6     6 1 99 return $_[0]->{'_serial'};
214             }
215              
216             #----------------------------------------------------------------------
217              
218             our $_use_be;
219             BEGIN {
220 7     7   616 $_use_be = 0;
221             }
222              
223             sub to_string_le {
224 8     8 0 36 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 7     7   41 use constant _LEADING_BYTE => map { ord } ('l', 'B');
  7         13  
  7         13  
  14         1604  
235              
236             sub _to_string {
237 8     8   16 my ($self) = @_;
238              
239 8         13 my ($body_m_sr, $fds_ar);
240              
241 8 100       30 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 5 50       44 $self->{'_body'},
245             );
246             }
247              
248             local $self->{'_hfields'}{ Protocol::DBus::Message::Header::FIELD()->{'UNIX_FDS'} } = [
249 8 50 66     52 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 8 100       92 $self->{'_hfields'},
261             ];
262              
263 8 50       127 my ($buf_sr) = Protocol::DBus::Marshal->can( $_use_be ? 'marshal_be' : 'marshal_le' )->(
264             Protocol::DBus::Message::Header::SIGNATURE(),
265             $data,
266             );
267              
268 8         39 Protocol::DBus::Pack::align_str($$buf_sr, 8);
269              
270 8 100       24 $$buf_sr .= $$body_m_sr if $body_m_sr;
271              
272 8         31 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 * All strings are character-decoded.
284              
285             =item * UNIX_FDs are normally represented as Perl filehandle objects.
286             If Protocol::DBus receives a UNIX_FD that doesn’t correspond to a received
287             file descriptor, the UNIX_FD will be represented as the number passed in
288             the raw D-Bus message, and a warning is thrown.
289              
290             =item * By default, variant signatures are discarded, and the values are
291             given by themselves. See L’s
292             C if you need an alternative mapping
293             method that preserves the signatures.
294              
295             =item * Other containers are represented as blessed references:
296             C, C, and
297             C. Currently these are just plain hash and
298             array references that are bless()ed; i.e., the classes themselves have no
299             methods defined (and aren’t even defined Perl namespaces).
300              
301             =back
302              
303             =head1 MAPPING PERL TO D-BUS
304              
305             =over
306              
307             =item * Use plain Perl scalars to represent all numeric and string types.
308             Strings B be character-decoded.
309              
310             =item * Use plain Perl filehandle objects to represent UNIX_FDs.
311              
312             =item * Use array references to represent D-Bus arrays and structs.
313             Use hash references for dicts.
314              
315             =item * Use a two-member array reference—signature then value—to represent
316             a D-Bus variant. (Note the inconsistency with the reverse mapping.)
317              
318             =back
319              
320             =head2 Examples
321              
322             =over
323              
324             =item * C - C<( $s0, [ $s1 ] )>
325              
326             =item * C - C<( \@ss )>
327              
328             =item * C - C<( \%ss )>
329              
330             =back
331              
332             =cut
333              
334             1;