File Coverage

blib/lib/Protocol/DBus/Peer.pm

Criterion	Covered	Total	%
statement	65	85	76.4
branch	6	16	37.5
condition	8	14	57.1
subroutine	17	24	70.8
pod	11	12	91.6
total	107	151	70.8

package Protocol::DBus::Peer;

use strict;
use warnings;

=encoding utf-8

=head1 NAME

Protocol::DBus::Peer - base class for a D-Bus peer

=head1 SYNOPSIS

    $dbus->send_call(
        interface => 'org.freedesktop.DBus.Properties',
        member => 'GetAll',
        signature => 's',
        path => '/org/freedesktop/DBus',
        destination => 'org.freedesktop.DBus',
        body => [ 'org.freedesktop.DBus' ],
    )->then( sub { .. } );

    my $msg = $dbus->get_message();

    # Same pattern as the IO::Handle method.
    $dbus->blocking(0);

    my $fileno = $dbus->fileno();

    $dbus->flush_write_queue() if $dbus->pending_send();

    # I’m not sure why you’d want to do this, but …
    $dbus->big_endian();

=head1 DESCRIPTION

This class contains D-Bus logic that is useful in both client and
server contexts. (Currently this distribution does not include a server
implementation.)

=cut

use Call::Context;
use Promise::ES6;

use Protocol::DBus::Message;
use Protocol::DBus::Parser;
use Protocol::DBus::WriteMsg;

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

=head1 METHODS

=head2 $msg = I->get_message()

This returns a single instace of L, or undef if
no message is available. It will also fire the appropriate “on_return”
method on METHOD_RETURN or ERROR messages.

The backend I/O logic reads data in chunks; thus, if there is a message
already available in the read buffer, no I/O is done. If you’re doing
non-blocking I/O then it is thus B that, every time the DBus socket
is readable, you call this function until undef is returned.

=cut

sub get_message {
    my $msg = $_[0]->{'_parser'}->get_message();

    if ($msg) {
        if (my $serial = $msg->get_header('REPLY_SERIAL')) {
            if (my $cb = delete $_[0]->{'_on_return'}{$serial}) {
                $cb->($msg);
            }
        }
    }

    return $msg;
}

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

=head2 I->flush_write_queue()

Same as L’s method of the same name.

=cut

sub flush_write_queue {
    if ($_[0]->{'_io'}->get_write_queue_count()) {
        return $_[0]->{'_io'}->flush_write_queue();
    }

    return 1;
}

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

=head2 I->send_call( %OPTS )

Send a METHOD_CALL message.

%OPTS are C, C, C, C, C,
and C. These do as you’d expect, but note that C, if given,
must be an array reference.

The return value is an instance of L that will resolve when
a METHOD_RETURN arrives in response, or reject when an ERROR arrives. The
promise both resolves and rejects with a L instance
that represents the response.

Note that exceptions can still happen (outside of the promise), e.g., if
your input is invalid or if there’s a socket I/O error.

=cut

use constant _METHOD_RETURN_NUM => Protocol::DBus::Message::Header::MESSAGE_TYPE()->{'METHOD_RETURN'};

sub send_call {
    my ($self, %opts) = @_;

    $self->_send_msg(
        %opts,
        type => 'METHOD_CALL',
    );

    # Don’t create a promise if we were called in void context.
    return defined(wantarray) && do {
        my $serial = $self->{'_last_sent_serial'};

        # Keep references to $self out of the callback
        # in order to avoid memory leaks.
        my $on_return_hr = $self->{'_on_return'} ||= {};

        return Promise::ES6->new( sub {
            my ($resolve, $reject) = @_;

            $on_return_hr->{$serial} = sub {
                if ($_[0]->get_type() == _METHOD_RETURN_NUM()) {
                    $resolve->($_[0]);
                }
                else {
                    $reject->($_[0]);
                }
            };
        } );
    };
}

=head2 I->send_return( $ORIG_MSG, %OPTS )

Send a METHOD_RETURN message.

Arguments are similar to C except for the header differences
that the D-Bus specification describes. Also, C is not given
directly but is instead inferred from the $ORIG_MSG. (Behavior is
undefined if this parameter is given directly.)

=cut

sub send_return {
    my ($self, $orig_msg, @opts_kv) = @_;

    return $self->_send_msg(
        _response_fields_from_orig_msg($orig_msg, \@opts_kv),
        type => 'METHOD_RETURN',
    );
}

=head2 I->send_error( $ORIG_MSG, %OPTS )

Like C, but sends an error instead. The
C parameter is required.

=cut

sub send_error {
    my ($self, $orig_msg, @opts_kv) = @_;

    return $self->_send_msg(
        _response_fields_from_orig_msg($orig_msg, \@opts_kv),
        type => 'ERROR',
    );
}

sub _response_fields_from_orig_msg {

    return (

        # This has to honor a passed “destination”
        # so that we can implement a D-Bus server in tests.
        destination => $_[0]->get_header('SENDER'),

        @{ $_[1] },

        # Reject callers’ attempts to set this one.
        reply_serial => $_[0]->get_serial(),
    );
}

=head2 I->send_signal( %OPTS )

Like C but sends a signal rather than a method call,
and a promise is not returned.

=cut

sub send_signal {
    my ($self, @opts_kv) = @_;

    return $self->_send_msg(
        @opts_kv,
        type => 'SIGNAL',
    );
}

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

=head2 I->big_endian()

Same interface as C, but this sets/gets/toggles whether to send
big-endian messages instead of little-endian.

By default this library uses the system’s native byte order, so you probably
have little need for this function.

=cut

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

    if (@_ > 0) {
        my $old = $self->{'_big_endian'};
        $self->{'_big_endian'} = !!$_[1];

        $self->{'_to_str_fn'} = 'to_string_' . ($_[1] ? 'be' : 'le');

        return $self->{'_big_endian'};
    }

    return !!$self->{'_big_endian'};
}

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

=head2 I->preserve_variant_signatures()

Same interface as C, but when this is enabled
variants are given as two-member array references ([ signature => value ]),
blessed as C instances.

For most Perl applications this is probably counterproductive.

=cut

sub preserve_variant_signatures {
    my $self = shift;

    return $self->{'_parser'}->preserve_variant_signatures(@_);
}

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

=head2 I->blocking()

Same interface as L’s method of the same name.

=cut

sub blocking {
    my $self = shift;

    return $self->{'_socket'}->blocking(@_);
}

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

=head2 I->fileno()

Returns the connection socket’s file descriptor.

=cut

sub fileno {
    return fileno $_[0]->{'_socket'};
}

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

=head2 I->pending_send()

Returns a boolean that indicates whether there is data queued up to send
to the server.

=cut

sub pending_send {
    return !!$_[0]->{'_io'}->get_write_queue_count();
}

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

# undocumented
sub new {
    my ($class, $socket) = @_;

    my $self = bless { _socket => $socket }, $class;

    $self->_set_up_peer_io( $socket );

    return $self;
}

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

sub _set_up_peer_io {
    my ($self, $socket) = @_;

    $self->{'_io'} = Protocol::DBus::WriteMsg->new( $socket )->enable_write_queue();
    $self->{'_parser'} = Protocol::DBus::Parser->new( $socket );

    return;
}

sub _send_msg {
    my ($self, %opts) = @_;

    my ($type, $body_ar, $flags) = delete @opts{'type', 'body', 'flags'};

    my @hargs = map {
        my $k = $_;
        $k =~ tr;
        ( $k => $opts{$_} );
    } keys %opts;

    my $serial = ++$self->{'_last_sent_serial'};

    my $msg = Protocol::DBus::Message->new(
        type => $type,
        hfields => \@hargs,
        flags => $flags,
        body => $body_ar,
        serial => $serial,
    );

    # Use native byte order by default.
    $self->{'_endian'} ||= (pack 'n', 1) eq (pack 'l', 1) ? 'be' : 'le';

    $self->{'_to_str_fn'} ||= "to_string_$self->{'_endian'}";

    my ($buf_sr, $fds_ar) = $msg->can($self->{'_to_str_fn'})->($msg);

    if ($fds_ar && @$fds_ar && !$self->supports_unix_fd()) {
        die "Cannot send file descriptors without UNIX FD support!";
    }

    $self->{'_io'}->enqueue_message( $buf_sr, $fds_ar );

    return $self->{'_io'}->flush_write_queue();
}

1;