File Coverage

blib/lib/Protocol/DBus/Client.pm
Criterion Covered Total %
statement 49 65 75.3
branch 7 18 38.8
condition 3 8 37.5
subroutine 14 17 82.3
pod 7 8 87.5
total 80 116 68.9


line stmt bran cond sub pod time code
1             package Protocol::DBus::Client;
2              
3 5     5   623060 use strict;
  5         22  
  5         142  
4 5     5   25 use warnings;
  5         10  
  5         152  
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 5     5   25 use parent 'Protocol::DBus::Peer';
  5         10  
  5         25  
33              
34 5     5   2342 use Protocol::DBus::Authn;
  5         15  
  5         143  
35 5     5   2229 use Protocol::DBus::Connect;
  5         19  
  5         143  
36 5     5   2204 use Protocol::DBus::Path;
  5         14  
  5         2835  
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 1136 my @addrs = Protocol::DBus::Path::system_message_bus();
52              
53 1         5 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 = Protocol::DBus::Connect::create_socket($addr);
75              
76 0         0 return __PACKAGE__->new(
77             socket => $socket,
78             authn_mechanism => 'EXTERNAL',
79             );
80             }
81              
82             #----------------------------------------------------------------------
83              
84             =head1 METHODS
85              
86             =head2 $done_yn = I->initialize()
87              
88             This returns truthy once the connection is ready to use and falsy until then.
89             In blocking I/O contexts the call will block.
90              
91             Note that this includes the initial C message and its response.
92              
93             Previously this function was called C and did not wait for
94             the C message’s response. The older name is retained
95             as an alias for backward compatibility.
96              
97             =cut
98              
99             sub initialize {
100 1     1 1 16 my ($self) = @_;
101              
102 1 50       13 if ($self->{'_authn'}->go()) {
103 1   33     43 $self->{'_sent_hello'} ||= do {
104             $self->send_call(
105             path => '/org/freedesktop/DBus',
106             interface => 'org.freedesktop.DBus',
107             destination => 'org.freedesktop.DBus',
108             member => 'Hello',
109             on_return => sub {
110 1     1   5 $self->{'_connection_name'} = $_[0]->get_body()->[0];
111             },
112 1         41 );
113             };
114              
115 1 50       3 if (!$self->{'_connection_name'}) {
116             GET_MESSAGE: {
117 1 50       2 if (my $msg = $self->SUPER::get_message()) {
  2         18  
118 2 100       12 return 1 if $self->{'_connection_name'};
119              
120 1         2 push @{ $self->{'_pending_received_messages'} }, $msg;
  1         4  
121              
122 1         3 redo GET_MESSAGE;
123             }
124             }
125             }
126             }
127              
128 0         0 return 0;
129             }
130              
131             *do_authn = \*initialize;
132              
133             #----------------------------------------------------------------------
134              
135             =head2 $yn = I->init_pending_send()
136              
137             This indicates whether there is data queued up to send for the initialization.
138             Only useful with non-blocking I/O.
139              
140             This function was previously called C; the former
141             name is retained for backward compatibility.
142              
143             =cut
144              
145             sub init_pending_send {
146 0     0 1 0 my ($self) = @_;
147              
148 0 0       0 if ($self->{'_connection_name'}) {
149 0         0 die "Don’t call this after initialize() is done!";
150             }
151              
152 0 0       0 if ($self->{'_sent_hello'}) {
153 0         0 return $self->pending_send();
154             }
155              
156 0         0 return $self->{'_authn'}->pending_send();
157             }
158              
159             *authn_pending_send = \*init_pending_send;
160              
161             #----------------------------------------------------------------------
162              
163             =head2 $yn = I->supports_unix_fd()
164              
165             Boolean that indicates whether this client supports UNIX FD passing.
166              
167             =cut
168              
169             sub supports_unix_fd {
170 0     0 1 0 my ($self) = @_;
171              
172 0         0 return $self->{'_authn'}->negotiated_unix_fd();
173             }
174              
175             #----------------------------------------------------------------------
176              
177             =head2 $msg = I->get_message()
178              
179             Same as in the base class, but for clients the initial “Hello” message and
180             its response are abstracted
181              
182             =cut
183              
184             sub get_message {
185 1     1 1 4 my ($self) = @_;
186              
187 1 50       5 die "initialize() is not finished!" if !$self->{'_connection_name'};
188              
189 1 50 33     15 if ($self->{'_pending_received_messages'} && @{ $self->{'_pending_received_messages'} }) {
  1         9  
190 1         4 return shift @{ $self->{'_pending_received_messages'} };
  1         6  
191             }
192              
193 5     5   40 no warnings 'redefine';
  5         10  
  5         1005  
194 0         0 *get_message = Protocol::DBus::Peer->can('get_message');
195              
196 0         0 return $_[0]->get_message();
197             }
198              
199             =head2 $name = I->get_connection_name()
200              
201             Returns the name of the connection.
202              
203             =cut
204              
205             sub get_connection_name {
206 1   50 1 1 41 return $_[0]->{'_connection_name'} || die 'No connection name known yet!';
207             }
208              
209             # undocumented for now
210             sub new {
211 1     1 0 857886 my ($class, %opts) = @_;
212              
213             my $authn = Protocol::DBus::Authn->new(
214             socket => $opts{'socket'},
215 1         86 mechanism => $opts{'authn_mechanism'},
216             );
217              
218 1         49 my $self = $class->SUPER::new( $opts{'socket'} );
219              
220 1         10 $self->{'_authn'} = $authn;
221              
222 1         6 return $self;
223             }
224              
225             1;