File Coverage

blib/lib/Protocol/DBus/Client.pm
Criterion Covered Total %
statement 64 92 69.5
branch 14 38 36.8
condition 5 17 29.4
subroutine 16 19 84.2
pod 7 8 87.5
total 106 174 60.9


line stmt bran cond sub pod time code
1             package Protocol::DBus::Client;
2              
3 6     6   784941 use strict;
  6         22  
  6         148  
4 6     6   25 use warnings;
  6         12  
  6         204  
5              
6             =encoding utf-8
7              
8             =head1 NAME
9              
10             Protocol::DBus::Client
11              
12             =head1 SYNOPSIS
13              
14             my $dbus = Protocol::DBus::Client::system();
15              
16             $dbus->initialize();
17              
18             =head1 DESCRIPTION
19              
20             This is the end class for use in DBus client applications. It subclasses
21             L.
22              
23             B This module will automatically send a “Hello” message after
24             authentication completes. That message’s response will be processed
25             automatically. Because this is part of the protocol’s handshake
26             logic rather than something useful for callers, it is abstracted away from
27             the caller. It is neither necessary nor productive for callers to send a
28             “Hello” message.
29              
30             =cut
31              
32 6     6   30 use parent 'Protocol::DBus::Peer';
  6         12  
  6         32  
33              
34 6     6   2457 use Protocol::DBus::Authn;
  6         12  
  6         164  
35 6     6   2093 use Protocol::DBus::Connect;
  6         13  
  6         147  
36 6     6   1920 use Protocol::DBus::Path;
  6         13  
  6         4019  
37              
38             =head1 STATIC FUNCTIONS
39              
40             =head2 system()
41              
42             Creates an instance of this class that includes a connection to the
43             system’s message bus.
44              
45             This does not do authentication; you’ll need to do that via the class’s
46             methods.
47              
48             =cut
49              
50             sub system {
51 1     1 1 1135 my @addrs = Protocol::DBus::Path::system_message_bus();
52              
53 1         4 return _create_local(@addrs);
54             }
55              
56             =head2 login_session()
57              
58             Like C but for the login session’s message bus.
59              
60             =cut
61              
62             sub login_session {
63 0     0 1 0 my @addrs = Protocol::DBus::Path::login_session_message_bus();
64              
65 0 0       0 if (!@addrs) {
66 0         0 die "Failed to identify login system message bus!";
67             }
68              
69 0         0 return _create_local(@addrs);
70             }
71              
72             sub _create_local {
73 1     1   3 my ($addr) = @_;
74 1         4 my ($socket, $bin_addr) = Protocol::DBus::Connect::create_socket($addr);
75              
76 1         5 return __PACKAGE__->new(
77             socket => $socket,
78             address => $bin_addr,
79             human_address => $addr->to_string(),
80             authn_mechanism => 'EXTERNAL',
81             );
82             }
83              
84             #----------------------------------------------------------------------
85              
86             =head1 METHODS
87              
88             =head2 $done_yn = I->initialize()
89              
90             This returns truthy once the connection is ready to use and falsy until then.
91             In blocking I/O contexts the call will block.
92              
93             Note that this automatically handles D-Bus’s initial C message and
94             its response.
95              
96             Previously this function was called C and did not wait for
97             the C message’s response. The older name is retained
98             as an alias for backward compatibility.
99              
100             =cut
101              
102             sub initialize {
103 3     3 1 37 my ($self) = @_;
104              
105 3 50 33     14 if ($self->_connect() && $self->{'_authn'}->go()) {
106 2   33     33 $self->{'_sent_hello'} ||= do {
107 2         19 my $connection_name_sr = \$self->{'_connection_name'};
108              
109             $self->send_call(
110             path => '/org/freedesktop/DBus',
111             interface => 'org.freedesktop.DBus',
112             destination => 'org.freedesktop.DBus',
113             member => 'Hello',
114 2     2   45 )->then( sub { $$connection_name_sr = $_[0]->get_body()->[0]; } );
  2         148  
115             };
116              
117 2 50       87 if (!$self->{'_connection_name'}) {
118             GET_MESSAGE: {
119 2 50       20 if (my $msg = $self->SUPER::get_message()) {
  4         33  
120 4 100       76 return 1 if $self->{'_connection_name'};
121              
122 2         8 push @{ $self->{'_pending_received_messages'} }, $msg;
  2         7  
123              
124 2         14 redo GET_MESSAGE;
125             }
126             }
127             }
128             }
129              
130 0 0       0 return $self->{'_connection_name'} ? 1 : 0;
131             }
132              
133             sub _connect {
134 3     3   6 my ($self) = @_;
135              
136 3         78 local $!;
137              
138 3 100       17 if (!$self->{'_connected'}) {
139 1   33     4 $self->{'_sent_connect'} ||= do {
140 1 50       57 if ( connect $self->{'_socket'}, $self->{'_address'} ) {
    50          
141 0         0 $self->{'_connected'} = 1;
142             }
143             elsif (!$!{'EINPROGRESS'}) {
144 1         48 die "connect($self->{'_human_address'}): $!";
145             }
146             };
147             }
148              
149 2 50       5 if (!$self->{'_connected'}) {
150              
151             # This non-blocking connect logic will ordinarily be unneeded
152             # since even in non-blocking mode a UNIX socket connect() doesn’t
153             # normally block. Where such a connect() *will* have to wait is
154             # when the server has no more space for a new connection.
155              
156 0         0 my $mask = q<>;
157 0         0 vec( $mask, fileno $self->{'_socket'}, 1 ) = 1;
158              
159 0         0 my $got = select undef, $mask, undef, 0;
160              
161 0 0       0 if ($got > 0) {
162 0         0 my $errno = getsockopt( $self->{'_socket'}, Socket::SOL_SOCKET(), Socket::SO_ERROR() );
163 0 0       0 if (!defined $errno) {
164 0         0 die "getsockopt(SOL_SOCKET, SO_ERROR): $!";
165             }
166              
167 0         0 local $! = unpack 'I', $errno;
168              
169 0 0       0 if (0 + $!) {
170 0         0 die "connect($self->{'_human_address'}): $!";
171             }
172             else {
173 0         0 $self->{'_connected'} = 1;
174             }
175             }
176             }
177              
178 2         22 return $self->{'_connected'};
179             }
180              
181             *do_authn = *initialize;
182              
183             #----------------------------------------------------------------------
184              
185             =head2 $yn = I->init_pending_send()
186              
187             This indicates whether there is data queued up to send for the initialization.
188             Only useful with non-blocking I/O.
189              
190             This function was previously called C; the former
191             name is retained for backward compatibility.
192              
193             =cut
194              
195             sub init_pending_send {
196 0     0 1 0 my ($self) = @_;
197              
198 0 0       0 if ($self->{'_connection_name'}) {
199 0         0 die "Don’t call this after initialize() is done!";
200             }
201              
202 0 0 0     0 return 1 if $self->{'_sent_connect'} && !$self->{'_connected'};
203              
204 0 0       0 if ($self->{'_sent_hello'}) {
205 0         0 return $self->pending_send();
206             }
207              
208 0         0 return $self->{'_authn'}->pending_send();
209             }
210              
211             *authn_pending_send = \*init_pending_send;
212              
213             #----------------------------------------------------------------------
214              
215             =head2 $yn = I->supports_unix_fd()
216              
217             Boolean that indicates whether this client supports UNIX FD passing.
218              
219             (See the main L documentation for details about
220             support for UNIX FD passing.)
221              
222             =cut
223              
224             sub supports_unix_fd {
225 0     0 1 0 my ($self) = @_;
226              
227 0         0 return $self->{'_authn'}->negotiated_unix_fd();
228             }
229              
230             #----------------------------------------------------------------------
231              
232             =head2 $msg = I->get_message()
233              
234             Same as in the base class, but for clients the initial “Hello” message and
235             its response are abstracted
236              
237             =cut
238              
239             sub get_message {
240 2     2 1 8 my ($self) = @_;
241              
242 2 50       8 die "initialize() is not finished!" if !$self->{'_connection_name'};
243              
244 2 50 33     10 if ($self->{'_pending_received_messages'} && @{ $self->{'_pending_received_messages'} }) {
  2         10  
245 2         3 return shift @{ $self->{'_pending_received_messages'} };
  2         8  
246             }
247              
248 6     6   38 no warnings 'redefine';
  6         12  
  6         609  
249 0         0 *get_message = Protocol::DBus::Peer->can('get_message');
250              
251 0         0 return $_[0]->get_message();
252             }
253              
254             =head2 $name = I->get_unique_bus_name()
255              
256             Returns the connection’s unique bus name.
257              
258             C is a historical alias for this method.
259              
260             =cut
261              
262             sub get_unique_bus_name {
263 2   50 2 1 71 return $_[0]->{'_connection_name'} || die 'No connection name known yet!';
264             }
265              
266             BEGIN {
267 6     6   759 *get_connection_name = *get_unique_bus_name;
268             }
269              
270             # undocumented for now
271             sub new {
272 3     3 0 922927 my ($class, %opts) = @_;
273              
274             my $authn = Protocol::DBus::Authn->new(
275             socket => $opts{'socket'},
276 3         162 mechanism => $opts{'authn_mechanism'},
277             );
278              
279 3         106 my $self = $class->SUPER::new( $opts{'socket'} );
280              
281 3         30 $self->{'_authn'} = $authn;
282              
283 3 100       34 if (my $address = $opts{'address'}) {
284 1         2 $self->{'_address'} = $address;
285 1         2 $self->{'_human_address'} = $opts{'human_address'};
286             }
287             else {
288 2         13 $self->{'_connected'} = 1;
289             }
290              
291 3         15 return $self;
292             }
293              
294             #sub DESTROY {
295             # print "DESTROYED: [$_[0]]\n";
296             #}
297              
298             1;