File Coverage

blib/lib/Protocol/DBus/Marshal.pm
Criterion Covered Total %
statement 169 188 89.8
branch 54 66 81.8
condition 9 16 56.2
subroutine 17 22 77.2
pod 0 8 0.0
total 249 300 83.0


line stmt bran cond sub pod time code
1             package Protocol::DBus::Marshal;
2              
3 7     7   72044 use strict;
  7         23  
  7         175  
4 7     7   29 use warnings;
  7         9  
  7         179  
5              
6 7     7   2284 use Protocol::DBus::Pack ();
  7         28  
  7         132  
7 7     7   2379 use Protocol::DBus::Signature ();
  7         18  
  7         13811  
8              
9             our $_ENDIAN_PACK;
10              
11             # Set this to get actual Perl filehandles in the
12             # message body. XXX FIXME This is a very hacky way to do it!
13             our $FILEHANDLES;
14              
15             # XXX FIXME Hackety-hack …
16             our $PRESERVE_VARIANT_SIGNATURES;
17              
18             # for testing
19             our $DICT_CANONICAL;
20              
21             our @_MARSHAL_FDS;
22              
23             # sig, data (array ref)
24             sub marshal_le {
25 30     30 0 10949 local $_ENDIAN_PACK = '<';
26 30         54 local @_MARSHAL_FDS;
27 30         87 return( _marshal(@_[0, 1]), \@_MARSHAL_FDS );
28             }
29              
30             # buf, buf offset, sig
31             sub unmarshal_le {
32 31     31 0 6220 local $_ENDIAN_PACK = '<';
33 31         89 return _unmarshal(@_);
34             }
35              
36             sub marshal_be {
37 0     0 0 0 local $_ENDIAN_PACK = '>';
38 0         0 local @_MARSHAL_FDS;
39 0         0 return( _marshal(@_[0, 1]), \@_MARSHAL_FDS );
40             }
41              
42             sub unmarshal_be {
43 0     0 0 0 local $_ENDIAN_PACK = '>';
44 0         0 return _unmarshal(@_);
45             }
46              
47             #----------------------------------------------------------------------
48              
49             sub _marshal {
50 164     164   278 my ($sig, $data, $buf_sr, $_data_are_not_list) = @_;
51              
52 164   100     295 $buf_sr ||= \do { my $v = q<> };
  30         101  
53              
54 164         273 my @scts = Protocol::DBus::Signature::split($sig);
55              
56 164         348 for my $si ( 0 .. $#scts ) {
57 211         271 my $sct = $scts[$si];
58              
59 211 100       317 my $datum = $_data_are_not_list ? $data : $data->[$si];
60              
61             # Arrays
62 211 100       497 if (index($sct, 'a') == 0) {
    100          
    100          
63 9         32 _marshal_array( $sct, $datum, $buf_sr);
64             }
65              
66             # Structs are given as arrays.
67             elsif (index($sct, '(') == 0) {
68 11         24 Protocol::DBus::Pack::align_str($$buf_sr, 8);
69              
70 11         17 my $struct_sig = substr($sig, 1, -1);
71              
72 11         20 _marshal( $struct_sig, $datum, $buf_sr );
73             }
74              
75             # Variants are given as two-member arrays.
76             elsif ($sct eq 'v') {
77 33         93 _marshal( g => $datum->[0], $buf_sr, 1 );
78 33         54 _marshal( $datum->[0], $datum->[1], $buf_sr, 1 );
79             }
80              
81             # Anything else is a basic type.
82             else {
83 158 100       285 if ($sct eq 'o') {
    100          
84 9 50       72 $datum =~ m<\A/(?:[A-Za-z0-9_]+(?:/[A-Za-z0-9_]+)*)?\z> or do {
85 0         0 die "Invalid object path: “$datum”";
86             };
87             }
88             elsif ($sct eq 'h') {
89 3         5 my $fd = fileno($datum);
90 3 50       7 die "fileno($datum) returned undef!" if !defined $fd;
91              
92 3         7 my ($idx) = grep { $_MARSHAL_FDS[$_] == $fd } 0 .. $#_MARSHAL_FDS;
  3         7  
93              
94 3 100       7 if (!defined $idx) {
95 2         3 $idx = @_MARSHAL_FDS;
96 2         4 push @_MARSHAL_FDS, $fd;
97             }
98              
99 3         4 $datum = $idx;
100             }
101              
102 158         377 Protocol::DBus::Pack::align_str($$buf_sr, Protocol::DBus::Pack::ALIGNMENT()->{$sct});
103              
104 158         238 my ($pack) = _get_pack_template($sct);
105              
106 158         257 $pack = "($pack)$_ENDIAN_PACK";
107 158         470 $$buf_sr .= pack( $pack, $datum );
108             }
109             }
110              
111 164         299 return $buf_sr;
112             }
113              
114             sub _marshal_array {
115 9     9   20 my ($sct, $data, $buf_sr) = @_;
116              
117 9         26 Protocol::DBus::Pack::align_str($$buf_sr, 4);
118              
119             # We’ll fill this in with the length below.
120 9         15 $$buf_sr .= "\0\0\0\0";
121              
122 9         15 my $array_start = length $$buf_sr;
123              
124             # Per the spec, array lengths do NOT include alignment bytes
125             # after the length. This only affects 8-byte-aligned types.
126 9         13 my $compensate_align8;
127              
128 9         15 substr($sct, 0, 1, q<>); # chop off the leading “a”
129              
130 9 100       24 if ($array_start % 8) {
131 3         4 $compensate_align8 = (0 == index($sct, '('));
132 3   100     12 $compensate_align8 ||= (0 == index($sct, '{'));
133 3   50     6 $compensate_align8 ||= ((Protocol::DBus::Pack::ALIGNMENT()->{$sct} || 0) == 8);
      66        
134             }
135              
136             # DICT_ENTRY arrays are given as plain Perl hashes
137 9 100       22 if (0 == index($sct, '{')) {
138 6         20 my $key_sig = substr($sct, 1, 1);
139 6         18 my $value_sig = substr($sct, 2, -1);
140              
141 6 100       38 for my $key ( $DICT_CANONICAL ? (sort keys %$data) : keys %$data ) {
142 24         53 Protocol::DBus::Pack::align_str($$buf_sr, 8);
143 24         65 _marshal($key_sig, $key, $buf_sr, 1);
144 24         45 _marshal( $value_sig, $data->{$key}, $buf_sr, 1);
145             }
146             }
147              
148             # Any other array is given as an array.
149             else {
150 3         5 for my $item ( @$data ) {
151 9         14 _marshal($sct, $item, $buf_sr, 1);
152             }
153             }
154              
155 9         22 my $array_len = length($$buf_sr) - $array_start;
156 9 100       28 $array_len -= 4 if $compensate_align8;
157              
158 9         35 substr( $$buf_sr, $array_start - 4, 4, pack("L$_ENDIAN_PACK", $array_len) );
159             }
160              
161             #----------------------------------------------------------------------
162              
163             sub _unmarshal {
164 67     67   117 my ($buf_sr, $buf_offset, $sig) = @_;
165              
166 67         81 my @items;
167              
168 67         101 my $buf_start = $buf_offset;
169 67         87 my $sig_offset = 0;
170              
171 67         123 while ($sig_offset < length($sig)) {
172 231         409 my $next_sct_len = Protocol::DBus::Signature::get_sct_length($sig, $sig_offset);
173              
174 231         505 my ($item, $item_length) = _unmarshal_sct(
175             $buf_sr,
176             $buf_offset,
177             substr( $sig, $sig_offset, $next_sct_len ),
178             );
179              
180 231         475 push @items, $item;
181              
182 231         253 $buf_offset += $item_length;
183 231         408 $sig_offset += $next_sct_len;
184             }
185              
186 67         182 return (\@items, $buf_offset - $buf_start);
187             }
188              
189             sub unmarshal_sct_le {
190 0     0 0 0 return _unmarshal_sct(@_);
191             }
192              
193             sub unmarshal_sct_be {
194 0     0 0 0 return _unmarshal_sct(@_);
195             }
196              
197             # SCT = “single complete type”.
198             # Returns the value plus its marshaled length.
199             sub _unmarshal_sct {
200 1713     1713   2463 my ($buf_sr, $buf_offset, $sct_sig) = @_;
201              
202 1713         1976 my $buf_start = $buf_offset;
203              
204 1713 100       3677 if (substr($sct_sig, 0, 1) eq 'a') {
    100          
    100          
205 110         209 Protocol::DBus::Pack::align($buf_offset, 4);
206              
207 110         259 my $array_len = unpack "\@$buf_offset L$_ENDIAN_PACK", $$buf_sr;
208 110         160 $buf_offset += 4; #uint32 length
209              
210 110         117 my $obj;
211              
212             # We parse arrays of DICT_ENTRY into a hash.
213 110 100       194 if (substr($sct_sig, 1, 1) eq '{') {
214              
215             # The key is always a basic type, so just one letter.
216 46         65 my $key_type = substr($sct_sig, 2, 1);
217              
218             # The value can be any SCT.
219 46         93 my $value_type = substr( $sct_sig, 3, Protocol::DBus::Signature::get_sct_length($sct_sig, 3) );
220              
221             # Do this here rather than in
222             # _unmarshal_to_hashref() to avoid
223             # the creation of an intermediate length.
224 46         105 Protocol::DBus::Pack::align($buf_offset, 8);
225              
226 46         95 $obj = _unmarshal_to_hashref($buf_sr, $buf_offset, $array_len, $key_type, $value_type);
227 46         63 $buf_offset += $array_len;
228             }
229              
230             # Anything else we parse normally.
231             else {
232 64         123 my $array_sig = substr( $sct_sig, 1, Protocol::DBus::Signature::get_sct_length($sct_sig, 1) );
233              
234 64         80 my @array_items;
235 64         116 $obj = bless \@array_items, 'Protocol::DBus::Type::Array';
236              
237             # If the array contents are 8-byte-aligned, then the array will
238             # actually be 4 bytes longer than this. But it doesn’t appear we
239             # need to care about that since _unmarshal_sct() accounts for that.
240 64         82 my $array_end = $buf_offset + $array_len;
241              
242 64         107 while ($buf_offset < $array_end) {
243 838         1186 my ($item, $item_length) = _unmarshal_sct($buf_sr, $buf_offset, $array_sig);
244              
245 838         1000 $buf_offset += $item_length;
246              
247 838         1501 push @array_items, $item;
248             }
249             }
250              
251 110         209 return ($obj, $buf_offset - $buf_start);
252             }
253             elsif (substr($sct_sig, 0, 1) eq '(') {
254 36         83 return _unmarshal_struct(@_);
255             }
256             elsif (substr($sct_sig, 0, 1) eq 'v') {
257 165         256 return _unmarshal_variant(@_);
258             }
259              
260 1402         1859 my ($pack_tmpl, $is_string) = _get_pack_template($sct_sig);
261              
262 1402         2992 Protocol::DBus::Pack::align($buf_offset, Protocol::DBus::Pack::ALIGNMENT()->{$sct_sig});
263              
264 1402         3162 my $val = unpack("\@$buf_offset ($pack_tmpl)$_ENDIAN_PACK", $$buf_sr);
265              
266 1402 50 33     2351 if ($FILEHANDLES && $sct_sig eq 'h') {
267 0   0     0 $val = $FILEHANDLES->[$val] || do {
268             warn "UNIX_FD ($val) received that doesn’t refer to a received file descriptor!\n";
269             $val;
270             };
271             }
272              
273 1402 100       3085 return ($val, $buf_offset - $buf_start + Protocol::DBus::Pack::WIDTH()->{$sct_sig} + ($is_string ? length($val) : 0));
274             }
275              
276             sub _unmarshal_variant {
277 165     165   232 my ($buf_sr, $buf_offset) = @_;
278              
279 165         180 my $buf_start = $buf_offset;
280              
281 165         264 my ($sig, $len) = _unmarshal_sct( $buf_sr, $buf_offset, 'g' );
282              
283 165 50       295 die sprintf("No sig ($len bytes?) from “%s”?", substr($$buf_sr, $buf_offset)) if !length $sig;
284              
285 165         192 $buf_offset += $len;
286              
287 165         236 (my $val, $len) = _unmarshal_sct( $buf_sr, $buf_offset, $sig );
288              
289             return(
290 165 50       403 $PRESERVE_VARIANT_SIGNATURES ? bless( [ $sig => $val ], 'Protocol::DBus::Type::Variant' ) : $val,
291             $len + $buf_offset - $buf_start,
292             );
293             }
294              
295             sub _get_pack_template {
296 1560     1560   1984 my ($sct_sig) = @_;
297              
298 1560         1750 my ($is_string, $pack_tmpl);
299 1560 100       2369 if ( $pack_tmpl = Protocol::DBus::Pack::STRING()->{$sct_sig} ) {
300 444         518 $is_string = 1;
301             }
302             else {
303 1116 50       1684 $pack_tmpl = Protocol::DBus::Pack::NUMERIC()->{$sct_sig} or do {
304 0         0 die "No basic type template for type “$sct_sig”!";
305             };
306              
307 1116         1176 if (!Protocol::DBus::Pack::CAN_64()) {
308             if ($pack_tmpl eq 'q') {
309             $pack_tmpl = ( $_ENDIAN_PACK eq '>' ) ? 'x4 l' : 'l x4';
310             }
311             elsif ($pack_tmpl eq 'Q') {
312             $pack_tmpl = ( $_ENDIAN_PACK eq '>' ) ? 'x4 L' : 'L x4';
313             }
314             }
315             }
316              
317 1560         2376 return ($pack_tmpl, $is_string);
318             }
319              
320             sub _unmarshal_to_hashref {
321 46     46   97 my ($buf_sr, $buf_offset, $array_len, $key_type, $value_type) = @_;
322              
323 46         58 my %items;
324 46         99 my $obj = bless \%items, 'Protocol::DBus::Type::Dict';
325              
326             # NB: We already align()ed this.
327              
328 46         76 my $end_offset = $buf_offset + $array_len;
329              
330 46         75 while ($buf_offset < $end_offset) {
331 157         326 Protocol::DBus::Pack::align($buf_offset, 8);
332              
333 157         255 my ($key, $len_in_buf) = _unmarshal_sct($buf_sr, $buf_offset, $key_type);
334              
335 157         223 $buf_offset += $len_in_buf;
336              
337 157         248 (my $val, $len_in_buf) = _unmarshal_sct($buf_sr, $buf_offset, $value_type);
338              
339 157         207 $buf_offset += $len_in_buf;
340              
341 157         408 $items{$key} = $val;
342             }
343              
344             # We don’t need to return the length.
345 46         93 return $obj;
346             }
347              
348             sub _unmarshal_struct {
349 36     36   56 my ($buf_sr, $buf_offset, $sct_sig) = @_;
350              
351             # Remove “()” and just parse as a series of types.
352 36         55 chop $sct_sig;
353 36         55 substr( $sct_sig, 0, 1, q<> );
354              
355 36         44 my $buf_start = $buf_offset;
356              
357 36         71 Protocol::DBus::Pack::align($buf_offset, 8);
358              
359 36         61 my ($items_ar, $len) = _unmarshal($buf_sr, $buf_offset, $sct_sig);
360 36         73 bless $items_ar, 'Protocol::DBus::Type::Struct';
361              
362 36         76 return ($items_ar, ($buf_offset - $buf_start) + $len);
363             }
364              
365             #----------------------------------------------------------------------
366             # The logic below is unused. I was under the impression that I’d need a
367             # way to determine if a message body’s length matches the given SIGNATURE,
368             # but of course we don’t because the header includes the body length.
369             #----------------------------------------------------------------------
370              
371             sub buffer_length_satisfies_signature_le {
372 19     19 0 41403 local $_ENDIAN_PACK = '<';
373 19         45 return (_buffer_length_satisfies_signature(@_))[0];
374             }
375              
376             sub buffer_length_satisfies_signature_be {
377 0     0 0 0 local $_ENDIAN_PACK = '>';
378 0         0 return (_buffer_length_satisfies_signature(@_))[0];
379             }
380              
381             sub _buffer_length_satisfies_signature {
382 25     25   53 my ($buf, $buf_offset, $sig) = @_;
383              
384 25         39 my $sig_offset = 0;
385              
386 25         53 while ($buf_offset <= length($buf)) {
387              
388             # We’re good if this passes because it means the buffer is longer
389             # than the passed-in signature needs it to be.
390 52 100       109 return (1, $buf_offset) if $sig_offset == length($sig);
391              
392 41         73 my $sct_length = Protocol::DBus::Signature::get_sct_length($sig, $sig_offset);
393              
394 41         58 my $next_sct = substr(
395             $sig,
396             $sig_offset,
397             $sct_length,
398             );
399              
400 41         45 $sig_offset += $sct_length;
401              
402 41 50       133 if ($next_sct eq 'v') {
    50          
    100          
    100          
403 0         0 my ($variant_sig, $len) = _unmarshal_sct($buf, $buf_offset, 'g');
404 0         0 $buf_offset += $len;
405              
406             # This has to recurse and preserve the offset.
407 0         0 my ($ok, $new_offset) = _buffer_length_satisfies_signature( $buf, $buf_offset, $variant_sig );
408 0 0       0 return 0 if !$ok;
409 0         0 $buf_offset = $new_offset;
410             }
411              
412             # signatures
413             elsif ($next_sct eq 'g') {
414             # 2 for the length byte and the trailing NUL
415 0         0 $buf_offset += 2 + unpack( "\@$buf_offset C", $buf )
416             }
417              
418             # strings and object paths
419             elsif ( Protocol::DBus::Pack::STRING()->{$next_sct} ) {
420 3         8 _add_uint32_variant_length(\$buf, \$buf_offset);
421 3         7 $buf_offset++; #trailing NUL
422             }
423              
424             # numerics
425             elsif ( my $width = Protocol::DBus::Pack::WIDTH()->{$next_sct} ) {
426 20         48 $buf_offset += $width;
427             }
428              
429             else {
430 18         23 my $char0 = substr($next_sct, 0, 1);
431              
432 18 100       38 if ($char0 eq 'a') {
    50          
433 12         21 _add_uint32_variant_length(\$buf, \$buf_offset);
434             }
435             elsif ($char0 eq '(') {
436 6         14 Protocol::DBus::Pack::align( $buf_offset, 8 );
437              
438 6         20 my ($ok, $new_offset) = _buffer_length_satisfies_signature( $buf, $buf_offset, substr($next_sct, 1, -1) );
439 6 100       20 return 0 if !$ok;
440 2         4 $buf_offset = $new_offset;
441             }
442             else {
443 0         0 die "unrecognized SCT: “$next_sct”";
444             }
445             }
446             }
447              
448 10         27 return 0;
449             }
450              
451             sub _add_uint32_variant_length {
452 15     15   28 my ($buf_sr, $buf_offset_sr) = @_;
453              
454 15         37 Protocol::DBus::Pack::align( $$buf_offset_sr, 4 );
455              
456 15 50       64 my $array_len = unpack(
457             "\@$$buf_offset_sr " . ($_ENDIAN_PACK eq '<' ? 'V' : 'N'),
458             $$buf_sr,
459             );
460              
461 15         19 $$buf_offset_sr += 4;
462 15         22 $$buf_offset_sr += $array_len;
463              
464 15         30 return;
465             }
466              
467             1;