line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Protocol::DBus::Message; |
2
|
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
|
612
|
use strict; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
163
|
|
4
|
6
|
|
|
6
|
|
29
|
use warnings; |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
147
|
|
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
|
|
2292
|
use Protocol::DBus::Marshal (); |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
119
|
|
20
|
6
|
|
|
6
|
|
2479
|
use Protocol::DBus::Message::Header (); |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
138
|
|
21
|
|
|
|
|
|
|
|
22
|
6
|
|
|
6
|
|
35
|
use constant _PROTOCOL_VERSION => 1; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
1452
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub parse { |
25
|
11
|
|
|
11
|
0
|
23509
|
my ($class, $buf_sr, $filehandles_ar) = @_; |
26
|
|
|
|
|
|
|
|
27
|
11
|
50
|
|
|
|
31
|
if ( my ($hdr, $hdr_len, $is_be) = Protocol::DBus::Message::Header::parse_simple($buf_sr) ) { |
28
|
|
|
|
|
|
|
|
29
|
11
|
50
|
|
|
|
44
|
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
|
|
|
|
29
|
if ($hdr->[4]) { |
34
|
8
|
50
|
|
|
|
19
|
die "No SIGNATURE header field!" if !defined $body_sig; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
11
|
|
|
|
|
18
|
my $body_data; |
38
|
|
|
|
|
|
|
|
39
|
11
|
100
|
|
|
|
19
|
if ($body_sig) { |
40
|
8
|
|
|
|
|
18
|
local $Protocol::DBus::Marshal::FILEHANDLES = $filehandles_ar; |
41
|
|
|
|
|
|
|
|
42
|
8
|
50
|
|
|
|
47
|
($body_data) = Protocol::DBus::Marshal->can( $is_be ? 'unmarshal_be' : 'unmarshal_le' )->($buf_sr, $hdr_len, $body_sig); |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
11
|
|
|
|
|
49
|
my %self = ( _body_sig => $body_sig ); |
46
|
11
|
|
|
|
|
21
|
@self{'_type', '_flags', '_serial', '_hfields', '_body'} = (@{$hdr}[1, 2, 5, 6], $body_data); |
|
11
|
|
|
|
|
51
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# Remove the unmarshaled bytes. |
49
|
11
|
|
|
|
|
41
|
substr( $$buf_sr, 0, $hdr_len + $hdr->[4], q<> ); |
50
|
|
|
|
|
|
|
|
51
|
11
|
|
|
|
|
56
|
return bless \%self, $class; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
0
|
return undef; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
6
|
|
|
6
|
|
42
|
use constant _REQUIRED => ('type', 'serial', 'hfields'); |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
5110
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub new { |
61
|
5
|
|
|
5
|
0
|
1023
|
my ($class, %opts) = @_; |
62
|
|
|
|
|
|
|
|
63
|
5
|
|
|
|
|
17
|
my @missing = grep { !defined $opts{$_} } _REQUIRED(); |
|
15
|
|
|
|
|
57
|
|
64
|
5
|
50
|
|
|
|
18
|
die "missing: @missing" if @missing; |
65
|
|
|
|
|
|
|
|
66
|
5
|
|
50
|
|
|
24
|
$opts{'type'} = Protocol::DBus::Message::Header::MESSAGE_TYPE()->{ $opts{'type'} } || die "Bad “type”: '$opts{'type'}'"; |
67
|
|
|
|
|
|
|
|
68
|
5
|
|
|
|
|
106
|
my $flags = 0; |
69
|
5
|
50
|
|
|
|
48
|
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
|
|
|
|
|
15
|
$opts{'flags'} = $flags; |
76
|
|
|
|
|
|
|
|
77
|
5
|
|
|
|
|
7
|
my %hfields; |
78
|
|
|
|
|
|
|
|
79
|
5
|
50
|
|
|
|
14
|
if ($opts{'hfields'}) { |
80
|
5
|
|
|
|
|
7
|
my $field_num; |
81
|
|
|
|
|
|
|
|
82
|
5
|
|
|
|
|
7
|
my $fi = 0; |
83
|
5
|
|
|
|
|
9
|
while ( $fi < @{ $opts{'hfields'} } ) { |
|
28
|
|
|
|
|
71
|
|
84
|
23
|
|
|
|
|
40
|
my ($name, $value) = @{ $opts{'hfields'} }[ $fi, 1 + $fi ]; |
|
23
|
|
|
|
|
45
|
|
85
|
23
|
|
|
|
|
32
|
$fi += 2; |
86
|
|
|
|
|
|
|
|
87
|
23
|
|
33
|
|
|
54
|
$field_num = Protocol::DBus::Message::Header::FIELD()->{$name} || do { |
88
|
|
|
|
|
|
|
die "Bad “hfields” name: “$name”"; |
89
|
|
|
|
|
|
|
}; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
$hfields{ $field_num } = [ |
92
|
23
|
|
|
|
|
111
|
Protocol::DBus::Message::Header::FIELD_SIGNATURE()->{$name}, |
93
|
|
|
|
|
|
|
$value, |
94
|
|
|
|
|
|
|
]; |
95
|
|
|
|
|
|
|
|
96
|
23
|
100
|
|
|
|
62
|
if ($field_num == Protocol::DBus::Message::Header::FIELD()->{'SIGNATURE'}) { |
97
|
3
|
|
|
|
|
7
|
$opts{'body_sig'} = $value; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
5
|
|
|
|
|
25
|
$opts{'hfields'} = bless \%hfields, 'Protocol::DBus::Type::Dict'; |
103
|
|
|
|
|
|
|
|
104
|
5
|
100
|
|
|
|
16
|
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
|
|
|
|
|
5
|
$opts{'body'} = \q<>; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
5
|
|
|
|
|
16
|
my %self = map { ( "_$_" => $opts{$_} ) } keys %opts; |
|
28
|
|
|
|
|
89
|
|
115
|
|
|
|
|
|
|
|
116
|
5
|
|
|
|
|
36
|
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
|
40
|
50
|
|
40
|
1
|
815
|
if ($_[1] =~ tr<0-9><>c) { |
132
|
40
|
|
50
|
|
|
147
|
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
|
172
|
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
|
4
|
|
|
4
|
1
|
1817
|
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
|
12427
|
my ($self, $name) = @_; |
167
|
|
|
|
|
|
|
|
168
|
10
|
|
33
|
|
|
51
|
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
|
82
|
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
|
46
|
my ($self, @names) = @_; |
193
|
|
|
|
|
|
|
|
194
|
2
|
50
|
|
|
|
5
|
die "Need flag names!" if !@names; |
195
|
|
|
|
|
|
|
|
196
|
2
|
|
|
|
|
3
|
for my $name (@names) { |
197
|
2
|
50
|
33
|
|
|
7
|
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
|
83
|
return $_[0]->{'_serial'}; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
our $_use_be; |
219
|
|
|
|
|
|
|
BEGIN { |
220
|
6
|
|
|
6
|
|
597
|
$_use_be = 0; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub to_string_le { |
224
|
5
|
|
|
5
|
0
|
22
|
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
|
|
41
|
use constant _LEADING_BYTE => map { ord } ('l', 'B'); |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
12
|
|
|
12
|
|
|
|
|
1795
|
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub _to_string { |
237
|
5
|
|
|
5
|
|
10
|
my ($self) = @_; |
238
|
|
|
|
|
|
|
|
239
|
5
|
|
|
|
|
9
|
my ($body_m_sr, $fds_ar); |
240
|
|
|
|
|
|
|
|
241
|
5
|
100
|
|
|
|
19
|
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
|
|
|
|
45
|
$self->{'_body'}, |
245
|
|
|
|
|
|
|
); |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
local $self->{'_hfields'}{ Protocol::DBus::Message::Header::FIELD()->{'UNIX_FDS'} } = [ |
249
|
5
|
50
|
66
|
|
|
29
|
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
|
|
|
|
26
|
$self->{'_hfields'}, |
261
|
|
|
|
|
|
|
]; |
262
|
|
|
|
|
|
|
|
263
|
5
|
50
|
|
|
|
102
|
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
|
|
|
|
|
20
|
Protocol::DBus::Pack::align_str($$buf_sr, 8); |
269
|
|
|
|
|
|
|
|
270
|
5
|
100
|
|
|
|
23
|
$$buf_sr .= $$body_m_sr if $body_m_sr; |
271
|
|
|
|
|
|
|
|
272
|
5
|
|
|
|
|
25
|
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; |