File Coverage

blib/lib/Protocol/DBus/Peer.pm

Criterion	Covered	Total	%
statement	59	78	75.6
branch	6	16	37.5
condition	7	11	63.6
subroutine	14	21	66.6
pod	11	12	91.6
total	97	138	70.2

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' ],
        on_return => sub { my ($msg) = @_ },
    );

    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 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 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,
C, and C. These do as you’d expect, with the following
caveats:

=over

=item * C, if given, must be an array reference. See
L for a discussion of how to map between D-Bus and
Perl.

=item * The C callback receives the server’s response
message (NB: either METHOD_RETURN or ERROR) as argument.

=back

=cut

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

    my $cb = delete $opts{'on_return'};

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

    if ($cb) {
        my $serial = $self->{'_last_sent_serial'};
        $self->{'_on_return'}{$serial} = $cb;
    }

    return $ret;
}

=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:

=over

=item * C is taken from the $ORIG_MSG. (Behavior is
undefined if this parameter is given directly.)

=item * There is no C parameter.

=back

=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.
There is no C parameter.

=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;