view release on metacpan or  search on metacpan

lib/Protocol/DBus/Client.pm  view on Meta::CPAN

sub system {
    my @addrs = Protocol::DBus::Path::system_message_bus();

    return _create_local(@addrs);
}

=head2 login_session()

Like C<system()> but for the login session’s message bus.

=cut

sub login_session {
    my @addrs = Protocol::DBus::Path::login_session_message_bus();

    if (!@addrs) {
        die "Failed to identify login system message bus!";
    }

    return _create_local(@addrs);
}

sub _create_local {
    my ($addr) = @_;
    my ($socket, $bin_addr) = Protocol::DBus::Connect::create_socket($addr);

    return __PACKAGE__->new(
        socket => $socket,
        address => $bin_addr,
        human_address => $addr->to_string(),
        authn_mechanism => 'EXTERNAL',
    );
}

#----------------------------------------------------------------------

=head1 METHODS

=head2 $done_yn = I<OBJ>->initialize()

This returns truthy once the connection is ready to use and falsy until then.
In blocking I/O contexts the call will block.

Note that this automatically handles D-Bus’s initial C<Hello> message and
its response.

Previously this function was called C<do_authn()> and did not wait for
the C<Hello> message’s response. The older name is retained
as an alias for backward compatibility.

=cut

sub initialize {
    my ($self) = @_;

    if ($self->_connect() && $self->{'_authn'}->go()) {
        $self->{'_sent_hello'} ||= do {
            my $connection_name_sr = \$self->{'_connection_name'};

            $self->send_call(
                path => '/org/freedesktop/DBus',
                interface => 'org.freedesktop.DBus',
                destination => 'org.freedesktop.DBus',
                member => 'Hello',
            )->then( sub { $$connection_name_sr = $_[0]->get_body()->[0]; } );
        };

        if (!$self->{'_connection_name'}) {
          GET_MESSAGE: {
                if (my $msg = $self->SUPER::get_message()) {
                    return 1 if $self->{'_connection_name'};

                    push @{ $self->{'_pending_received_messages'} }, $msg;

                    redo GET_MESSAGE;
                }
            }
        }
    }

    return $self->{'_connection_name'} ? 1 : 0;
}

sub _connect {
    my ($self) = @_;

    local $!;

    if (!$self->{'_connected'}) {
        $self->{'_sent_connect'} ||= do {
            if ( connect $self->{'_socket'}, $self->{'_address'} ) {
                $self->{'_connected'} = 1;
            }
            elsif (!$!{'EINPROGRESS'}) {
                die "connect($self->{'_human_address'}): $!";
            }
        };
    }

    if (!$self->{'_connected'}) {

        # This non-blocking connect logic will ordinarily be unneeded
        # since even in non-blocking mode a UNIX socket connect() doesn’t
        # normally block. Where such a connect() *will* have to wait is
        # when the server has no more space for a new connection.

        my $mask = q<>;
        vec( $mask, fileno $self->{'_socket'}, 1 ) = 1;

        my $got = select undef, $mask, undef, 0;

        if ($got > 0) {
            my $errno = getsockopt( $self->{'_socket'}, Socket::SOL_SOCKET(), Socket::SO_ERROR() );
            if (!defined $errno) {
                die "getsockopt(SOL_SOCKET, SO_ERROR): $!";
            }

            local $! = unpack 'I', $errno;

            if (0 + $!) {
                die "connect($self->{'_human_address'}): $!";
            }
            else {