Protocol-DBus
view release on metacpan or search on metacpan
[subroutine signatures](https://metacpan.org/pod/perlsub#Signatures).)
For blocking I/O:
my $dbus = Protcol::DBus::Client::system();
# Authentication and “Hello†call/response:
$dbus->initialize();
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus.Properties',
member => 'GetAll',
destination => 'org.freedesktop.DBus',
signature => 's',
body => [ 'org.freedesktop.DBus' ],
)->then( sub ($resp_msg) { .. } );
my $msg = $dbus->get_message();
For non-blocking I/O, it is recommended to use an event loop.
This distribution includes some connectors to simplify that work:
- [Protocol::DBus::Client::IOAsync](https://metacpan.org/pod/Protocol%3A%3ADBus%3A%3AClient%3A%3AIOAsync) (for [IO::Async](https://metacpan.org/pod/IO%3A%3AAsync))
- [Protocol::DBus::Client::Mojo](https://metacpan.org/pod/Protocol%3A%3ADBus%3A%3AClient%3A%3AMojo) (for [Mojolicious](https://metacpan.org/pod/Mojolicious))
- [Protocol::DBus::Client::AnyEvent](https://metacpan.org/pod/Protocol%3A%3ADBus%3A%3AClient%3A%3AAnyEvent) (for [AnyEvent](https://metacpan.org/pod/AnyEvent))
You can also interface with a manually-written event loop.
See [the example](#example-using-manually-written-event-loop) below.
# DESCRIPTION
<div>
<a href='https://coveralls.io/github/FGasper/p5-Protocol-DBus?branch=master'><img src='https://coveralls.io/repos/github/FGasper/p5-Protocol-DBus/badge.svg?branch=master' alt='Coverage Status' /></a>
</div>
This is an original, pure-Perl implementation of client messaging logic for
[the D-Bus protocol](https://dbus.freedesktop.org/doc/dbus-specification.html).
It’s not much more than an implementation of the wire protocol; it doesn’t
know about objects, services, or anything else besides the actual messages.
This is fine, of course, if all you want to do is, e.g., replace
an invocation of `gdbus` or `dbus-send` with pure Perl.
If you want an interface that mimics D-Bus’s actual object system,
you’ll need to implement it yourself or use something like [Net::DBus](https://metacpan.org/pod/Net%3A%3ADBus).
(See ["DIFFERENCES FROM Net::DBus"](#differences-from-net-dbus) below.)
# EXAMPLES
See [Protocol::DBus::Client](https://metacpan.org/pod/Protocol%3A%3ADBus%3A%3AClient) and the above samples for a starting point.
Also see the distribution’s `examples/` directory.
# DIFFERENCES FROM Net::DBus
[Net::DBus](https://metacpan.org/pod/Net%3A%3ADBus) is an XS binding to
[libdbus](https://www.freedesktop.org/wiki/Software/dbus/),
the reference D-Bus implementation. It is CPAN’s most mature D-Bus
implementation.
There are several reasons why you might prefer this module instead,
though, such as:
- Net::DBus discerns how to send a method call via D-Bus introspection.
While handy, this costs extra network overhead and requires an XML parser.
With Protocol::DBus you give a signature directly to send a method call.
- Protocol::DBus can work smoothly with any event system you like,
examples/anyevent.pl view on Meta::CPAN
my $msg = $dbus->get_message;
$waiter->send($msg);
});
print Dumper $waiter->recv;
$waiter = AnyEvent->condvar;
$dbus->send_call(
member => 'CreateTransaction',
path => '/org/freedesktop/PackageKit',
destination => 'org.freedesktop.PackageKit',
interface => 'org.freedesktop.PackageKit',
);
my $trans_path = shift @{$waiter->recv->get_body};
$waiter = AnyEvent->condvar;
$w = AnyEvent->io(fh => $dbus->fileno(), poll => 'r',
cb => sub {
my $msg = $dbus->get_message();
print Dumper $msg->get_body();
if ($msg->get_header('MEMBER') eq 'Finished') {
$waiter->send;
}
});
$dbus->send_call(
member => 'AddMatch',
signature => 's',
destination => 'org.freedesktop.DBus',
interface => 'org.freedesktop.DBus',
path => '/org/freedesktop/DBus',
body => [
"path='$trans_path'"
]
);
$dbus->send_call(
member => 'GetPackages',
signature => 't',
path => $trans_path,
destination => 'org.freedesktop.PackageKit',
interface => 'org.freedesktop.PackageKit.Transaction',
body => [ 4 ],
);
$waiter->recv;
examples/anyevent_monitor.pl view on Meta::CPAN
printf "%s from %s$/", $type, $msg->get_header('SENDER');
printf "\tType: %s.%s$/", map { $msg->get_header($_) } qw( INTERFACE MEMBER );
printf "\tBody: (%s) %s$/", $msg->get_header('SIGNATURE'), $json->encode($msg->get_body());
print $/;
} );
$dbus->initialize()->then( sub ($msgr) {
$msgr->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus',
member => 'AddMatch',
destination => 'org.freedesktop.DBus',
signature => 's',
body => [ q<> ],
);
} );
AnyEvent->condvar()->recv();
}
1;
examples/credentials.pl view on Meta::CPAN
# Wait for the initial hello acknowledgement
# so we know our connnection name.
$dbus->get_message();
for my $func ( qw( GetConnectionUnixUser GetConnectionCredentials ) ) {
print "$func:\n";
my $got_response;
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus',
destination => 'org.freedesktop.DBus',
signature => 's',
member => $func,
body => [ $dbus->get_unique_bus_name() ],
)->then( sub {
$got_response = 1;
print Dumper shift;
} );
$dbus->get_message() while !$got_response;
}
examples/introspect.pl view on Meta::CPAN
my $dbus = $> ? Protocol::DBus::Client::login_session() : Protocol::DBus::Client::system();
$dbus->preserve_variant_signatures(1);
$dbus->initialize();
my $got_response;
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus.Properties',
destination => 'org.freedesktop.DBus',
signature => 's',
member => 'GetAll',
body => ['org.freedesktop.DBus'],
)->then( sub {
$got_response = 1;
print "got getall response\n";
print Dumper shift;
} );
$dbus->get_message() while !$got_response;
examples/introspect_nb.pl view on Meta::CPAN
}
}
printf "done authn; unique bus name: %s\n", $dbus->get_unique_bus_name();
#----------------------------------------------------------------------
my $got_response;
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus.Properties',
destination => 'org.freedesktop.DBus',
signature => 's',
member => 'GetAll',
body => ['org.freedesktop.DBus'],
)->then( sub {
$got_response = 1;
print "got getall response\n";
print Dumper shift;
} );
while (!$got_response) {
my $win = $dbus->pending_send() || q<>;
$win &&= $mask;
examples/packagekit.pl view on Meta::CPAN
use Protocol::DBus::Client;
my $dbus = $> ? Protocol::DBus::Client::login_session() : Protocol::DBus::Client::system();
$dbus->initialize();
$dbus->get_message();
$dbus->send_call(
member => 'CreateTransaction',
path => '/org/freedesktop/PackageKit',
destination => 'org.freedesktop.PackageKit',
interface => 'org.freedesktop.PackageKit',
);
my $trans_path = shift @{$dbus->get_message()->get_body()};
$dbus->send_call(
member => 'AddMatch',
signature => 's',
destination => 'org.freedesktop.DBus',
interface => 'org.freedesktop.DBus',
path => '/org/freedesktop/DBus',
body => [
"path='$trans_path'"
]
);
$dbus->send_call(
member => 'GetPackages',
signature => 't',
path => $trans_path,
destination => 'org.freedesktop.PackageKit',
interface => 'org.freedesktop.PackageKit.Transaction',
body => [ 4 ],
);
while (1) {
my $msg = $dbus->get_message();
print Dumper $msg->get_body();
if ($msg->get_header('MEMBER') eq 'Finished') {
last;
examples/receive.pl view on Meta::CPAN
use Protocol::DBus::Client;
my $dbus = $> ? Protocol::DBus::Client::login_session() : Protocol::DBus::Client::system();
$dbus->initialize();
$dbus->send_call(
member => 'AddMatch',
signature => 's',
destination => 'org.freedesktop.DBus',
interface => 'org.freedesktop.DBus',
path => '/org/freedesktop/DBus',
body => [
"type='signal'",
]
);
print Dumper( $dbus->get_message() ) while 1;
examples/sha1.pl view on Meta::CPAN
my $dbus = Protocol::DBus::Client->new(
authn_mechanism => 'DBUS_COOKIE_SHA1',
socket => $s,
);
$dbus->initialize();
my $got_response;
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus.Properties',
destination => 'org.freedesktop.DBus',
signature => 's',
member => 'GetAll',
body => ['org.freedesktop.DBus'],
)->then( sub {
$got_response = 1;
print "got getall response\n";
print Dumper shift;
} );
$dbus->get_message() while !$got_response;
examples/unix_fds.pl view on Meta::CPAN
# $dbus->big_endian(1);
$dbus->initialize();
my $signal_name = 'ProtocolDBusFDPass';
$dbus->send_call(
member => 'AddMatch',
signature => 's',
destination => 'org.freedesktop.DBus',
interface => 'org.freedesktop.DBus',
path => '/org/freedesktop/DBus',
body => [
"type=signal,member=$signal_name",
]
);
$dbus->get_message();
my $recv_name = $dbus->get_unique_bus_name();
my $pid = fork or do {
my $dbus = $> ? Protocol::DBus::Client::login_session() : Protocol::DBus::Client::system();
$dbus->initialize();
pipe( my $r, my $w );
$dbus->send_signal(
member => $signal_name,
signature => 'h',
destination => $recv_name,
interface => 'org.freedesktop.DBus',
path => '/org/freedesktop/DBus',
body => [$w],
);
print "$$ receives: " . <$r>;
exit;
};
close STDOUT;
lib/Protocol/DBus.pm view on Meta::CPAN
L<subroutine signatures|perlsub/Signatures>.)
For blocking I/O:
my $dbus = Protcol::DBus::Client::system();
# Authentication and “Hello†call/response:
$dbus->initialize();
$dbus->send_call(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus.Properties',
member => 'GetAll',
destination => 'org.freedesktop.DBus',
signature => 's',
body => [ 'org.freedesktop.DBus' ],
)->then( sub ($resp_msg) { .. } );
my $msg = $dbus->get_message();
For non-blocking I/O, it is recommended to use an event loop.
This distribution includes some connectors to simplify that work:
=over
=item * L<Protocol::DBus::Client::IOAsync> (for L<IO::Async>)
lib/Protocol/DBus.pm view on Meta::CPAN
=head1 DESCRIPTION
=begin html
<a href='https://coveralls.io/github/FGasper/p5-Protocol-DBus?branch=master'><img src='https://coveralls.io/repos/github/FGasper/p5-Protocol-DBus/badge.svg?branch=master' alt='Coverage Status' /></a>
=end html
This is an original, pure-Perl implementation of client messaging logic for
L<the D-Bus protocol|https://dbus.freedesktop.org/doc/dbus-specification.html>.
It’s not much more than an implementation of the wire protocol; it doesn’t
know about objects, services, or anything else besides the actual messages.
This is fine, of course, if all you want to do is, e.g., replace
an invocation of C<gdbus> or C<dbus-send> with pure Perl.
If you want an interface that mimics D-Bus’s actual object system,
you’ll need to implement it yourself or use something like L<Net::DBus>.
(See L</DIFFERENCES FROM Net::DBus> below.)
lib/Protocol/DBus.pm view on Meta::CPAN
=head1 EXAMPLES
See L<Protocol::DBus::Client> and the above samples for a starting point.
Also see the distribution’s F<examples/> directory.
=head1 DIFFERENCES FROM Net::DBus
L<Net::DBus> is an XS binding to
L<libdbus|https://www.freedesktop.org/wiki/Software/dbus/>,
the reference D-Bus implementation. It is CPAN’s most mature D-Bus
implementation.
There are several reasons why you might prefer this module instead,
though, such as:
=over
=item * Net::DBus discerns how to send a method call via D-Bus introspection.
While handy, this costs extra network overhead and requires an XML parser.
lib/Protocol/DBus/Authn/Mechanism/DBUS_COOKIE_SHA1.pm view on Meta::CPAN
package Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1;
# https://dbus.freedesktop.org/doc/dbus-specification.html#auth-mechanisms-sha
use strict;
use warnings;
use parent qw( Protocol::DBus::Authn::Mechanism );
use Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces ();
use File::Spec ();
lib/Protocol/DBus/Client.pm view on Meta::CPAN
=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;
lib/Protocol/DBus/Peer.pm view on Meta::CPAN
=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();
t/Protocol-DBus-Authn-Mechanism-DBUS_SESSION_SHA1.t view on Meta::CPAN
my $ruid_hex = unpack('H*', $username);
is(
$line,
"AUTH DBUS_COOKIE_SHA1 $ruid_hex",
'first line',
);
{
open my $wfh, '>>', "$keyrings_dir/org_freedesktop_general";
printf {$wfh} "%s %s %s$/", 1240694009, time, 'b0fa6f735d59ed7bd0394faaa04d6f78adcbe258bd90b050';
}
$dbsrv->send_line('DATA 6f72675f667265656465736b746f705f67656e6572616c2031323430363934303039206634376636313633643563633432306433616163313333363838303961646463');
$line = $dbsrv->get_line();
is(
$line,
'DATA 373733306361653031666562646464376431323361353261386437343264633231323933306464652066373737333337623064613830633238363835376163343830613737353864353239346533376231',
t/Protocol-DBus-Authn-Mechanism-DBUS_SESSION_SHA1.t view on Meta::CPAN
my $ruid_hex = unpack('H*', $username);
is(
$line,
"AUTH DBUS_COOKIE_SHA1 $ruid_hex",
'first line',
);
{
open my $wfh, '>>', "$keyrings_dir/org_freedesktop_general";
printf {$wfh} "%s %s %s$/", 1240694009, time, 'b0fa6f735d59ed7bd0394faaa04d6f78adcbe258bd90b050';
}
$dbsrv->send_line('DATA 6f72675f667265656465736b746f705f67656e6572616c2031323430363934303039206634376636313633643563633432306433616163313333363838303961646463');
$line = $dbsrv->get_line();
is(
$line,
'DATA 373733306361653031666562646464376431323361353261386437343264633231323933306464652066373737333337623064613830633238363835376163343830613737353864353239346533376231',
t/Protocol-DBus-Authn-Mechanism-EXTERNAL.t view on Meta::CPAN
ok( $client->get_unique_bus_name(), 'Unique bus name is set after initialize()' );
my $msg = $client->get_message();
cmp_deeply(
$msg,
all(
Isa('Protocol::DBus::Message'),
methods(
[ type_is => 'SIGNAL' ] => 1,
[ get_header => 'PATH' ] => '/org/freedesktop/DBus',
[ get_header => 'INTERFACE' ] => 'org.freedesktop.DBus',
[ get_header => 'MEMBER' ] => 'NameAcquired',
[ get_header => 'DESTINATION' ] => $CLIENT_NAME,
[ get_header => 'SENDER' ] => 'org.freedesktop.DBus',
[ get_header => 'SIGNATURE' ] => 's',
get_body => [$CLIENT_NAME],
),
),
'Client received “NameAcquired†message via get_message()',
);
};
sub _server_finish_authn {
my ($dbsrv) = @_;
t/Protocol-DBus-Authn-Mechanism-EXTERNAL.t view on Meta::CPAN
my $srv = Protocol::DBus::Peer->new( $dbsrv->socket() );
my $hello = $srv->get_message();
cmp_deeply(
$hello,
all(
Isa('Protocol::DBus::Message'),
methods(
[ type_is => 'METHOD_CALL' ] => 1,
[ get_header => 'PATH' ] => '/org/freedesktop/DBus',
[ get_header => 'INTERFACE' ] => 'org.freedesktop.DBus',
[ get_header => 'MEMBER' ] => 'Hello',
[ get_header => 'DESTINATION' ] => 'org.freedesktop.DBus',
get_body => undef,
),
),
'Client sent “Hello†message',
);
# Test that the client receives this message from get_message().
$srv->send_signal(
path => '/org/freedesktop/DBus',
interface => 'org.freedesktop.DBus',
member => 'NameAcquired',
destination => $CLIENT_NAME,
sender => 'org.freedesktop.DBus',
signature => 's',
body => [$CLIENT_NAME],
);
$srv->send_return(
$hello,
destination => $CLIENT_NAME,
sender => 'org.freedesktop.DBus',
signature => 's',
body => [$CLIENT_NAME],
);
return;
}
my @tests = (
{
skip_if => sub { $INC{'Socket/MsgHdr.pm'} && 'Socket::MsgHdr is already loaded.' },
t/Protocol-DBus-Marshal.t view on Meta::CPAN
},
{
in => [ '(t)', [ [5] ] ],
out => "\x05\0\0\0\0\0\0\0",
},
)
: ()
),
{
in => [ v => [ [ o => '/org/freedesktop/NetworkManager' ] ] ],
out => "\1o\0\0\37\0\0\0/org/freedesktop/NetworkManager\0",
},
{
in => [ '(s)', [ ['hello'] ] ],
out => "\5\0\0\0hello\0",
},
{
in => [ '(ss)', [ ['hello', 'there'] ] ],
out => "\5\0\0\0hello\0" . "\0\0". "\5\0\0\0there\0",
},
{
in => [
'ua(yv)',
[
127,
[
[ 1 => [ o => '/org/freedesktop/NetworkManager' ] ],
[ 3 => [ s => 'Introspect' ] ],
[ 2 => [ s => 'org.freedesktop.DBus.Introspectable' ] ],
[ 6 => [ s => 'org.freedesktop.NetworkManager' ] ],
],
],
],
out => "\x7f\0\0\0\227\0\0\0\1\1o\0\37\0\0\0/org/freedesktop/NetworkManager\0\3\1s\0\n\0\0\0Introspect\0\0\0\0\0\0\2\1s\0#\0\0\0org.freedesktop.DBus.Introspectable\0\0\0\0\0\6\1s\0\36\0\0\0org.freedesktop.NetworkManager\0",
},
{
in => [
'uua(yv)',
[
2,
127,
[
[ 1 => [ o => '/org/freedesktop/NetworkManager' ] ],
[ 3 => [ s => 'Introspect' ] ],
[ 2 => [ s => 'org.freedesktop.DBus.Introspectable' ] ],
[ 6 => [ s => 'org.freedesktop.NetworkManager' ] ],
],
],
],
out => "\2\0\0\0\x7f\0\0\0\227\0\0\0\0\0\0\0\1\1o\0\37\0\0\0/org/freedesktop/NetworkManager\0\3\1s\0\n\0\0\0Introspect\0\0\0\0\0\0\2\1s\0#\0\0\0org.freedesktop.DBus.Introspectable\0\0\0\0\0\6\1s\0\36\0\0\0org.freedesktop.NetworkManager\0",
},
{
in => [
'uua{yv}',
[
127,
2,
{
1 => [ o => '/org/freedesktop/NetworkManager' ],
},
],
],
out => "\x7f\0\0\0\2\0\0\0(\0\0\0\0\0\0\0\1\1o\0\37\0\0\0/org/freedesktop/NetworkManager\0",
},
# Note the reuse of index 1 (STDOUT).
{
in => [
'hhyh',
[ \*STDERR, \*STDOUT, 2, \*STDOUT ],
],
out => "\0\0\0\0\1\0\0\0\x02\0\0\0\1\0\0\0",
out_fds => [ map { fileno $_ } (\*STDERR, \*STDOUT) ],
t/Protocol-DBus-Marshal.t view on Meta::CPAN
in => ["\0\0\0\0" . "\x10\0\0\0" . "\x0a\0\0\0" . "\0\1\0\0" . "\x02\0\0\0" . "\x10\0\0\0", 2, 'a{uu}'],
out => [
[ all(
Isa('Protocol::DBus::Type::Dict'),
noclass( { 10 => 256, 2 => 16 } ),
) ],
22,
],
},
{
in => ["\0\0\0\0\237\0\0\0\1\1o\0.\0\0\0/org/freedesktop/systemd1/unit/spamd_2eservice\0\0\3\1s\0\6\0\0\0GetAll\0\0\2\1s\0\37\0\0\0org.freedesktop.DBus.Properties\0\6\1s\0\30\0\0\0org.freedesktop.systemd1\0\0\0\0\0\0\0\0\10\1g\0\1s\0\0", 1, '...
out => [
[ all(
Isa('Protocol::DBus::Type::Array'),
noclass( [
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
1,
'/org/freedesktop/systemd1/unit/spamd_2eservice',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
3,
'GetAll',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
2,
'org.freedesktop.DBus.Properties',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
6,
'org.freedesktop.systemd1',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
8,
's',
] ),
),
] ),
) ],
166,
],
},
{
in => ["l\1\0\1\5\0\0\0\1\0\0\0\237\0\0\0\1\1o\0.\0\0\0/org/freedesktop/systemd1/unit/spamd_2eservice\0\0\3\1s\0\6\0\0\0GetAll\0\0\2\1s\0\37\0\0\0org.freedesktop.DBus.Properties\0\6\1s\0\30\0\0\0org.freedesktop.systemd1\0\0\0\0\0\0\0\0\10\1g\...
out => [
[
108,
1,
0,
1,
5,
1,
all(
Isa('Protocol::DBus::Type::Array'),
noclass( [
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
1,
'/org/freedesktop/systemd1/unit/spamd_2eservice',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
3,
'GetAll',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
2,
'org.freedesktop.DBus.Properties',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
6,
'org.freedesktop.systemd1',
] ),
),
all(
Isa('Protocol::DBus::Type::Struct'),
noclass( [
8,
's',
] ),
),
] ),
t/Protocol-DBus-Message.t view on Meta::CPAN
use Protocol::DBus::Marshal;
my @stringify_le = (
{
label => 'bare “Hello†message',
in => {
type => 'METHOD_CALL',
serial => 1,
hfields => [
PATH => '/org/freedesktop/DBus',
INTERFACE => 'org.freedesktop.DBus',
MEMBER => 'Hello',
DESTINATION => 'org.freedesktop.DBus',
],
},
out => "l\1\0\1\0\0\0\0\1\0\0\0m\0\0\0\1\1o\0\25\0\0\0/org/freedesktop/DBus\0\0\0\2\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\3\1s\0\5\0\0\0Hello\0\0\0\6\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0",
},
{
label => '“GetAll†call',
in => {
type => 'METHOD_CALL',
serial => 3,
hfields => [
PATH => '/org/freedesktop/DBus',
INTERFACE => 'org.freedesktop.DBus.Properties',
MEMBER => 'GetAll',
DESTINATION => 'org.freedesktop.DBus',
SIGNATURE => 's',
],
body => [ 'org.freedesktop.DBus' ],
},
out => "l\1\0\1\31\0\0\0\3\0\0\0\177\0\0\0\1\1o\0\25\0\0\0/org/freedesktop/DBus\0\0\0\2\1s\0\37\0\0\0org.freedesktop.DBus.Properties\0\3\1s\0\6\0\0\0GetAll\0\0\6\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\10\1g\0\1s\0\0\24\0\0\0org.freedesktop...
},
);
for my $t (@stringify_le) {
local $Protocol::DBus::Marshal::DICT_CANONICAL = 1;
my $msg = Protocol::DBus::Message->new( %{ $t->{'in'} } );
my ($out_sr) = $msg->to_string_le();
t/Protocol-DBus-Message.t view on Meta::CPAN
local $Data::Dumper::Useqq = 1;
return Dumper($thing);
}
#----------------------------------------------------------------------
my @parse_le = (
{
label => 'bare “Hello†message',
in => "l\1\0\1\0\0\0\0\1\0\0\0m\0\0\0\1\1o\0\25\0\0\0/org/freedesktop/DBus\0\0\0\3\1s\0\5\0\0\0Hello\0\0\0\2\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\6\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0",
methods => [
get_type => Protocol::DBus::Message::Header::MESSAGE_TYPE()->{'METHOD_CALL'},
[ type_is => 'METHOD_CALL' ] => 1,
get_flags => 0,
get_serial => 1,
[ get_header => 'PATH'] => '/org/freedesktop/DBus',
[ get_header => 'MEMBER'] => 'Hello',
[ get_header => 'INTERFACE'] => 'org.freedesktop.DBus',
[ get_header => 'DESTINATION'] => 'org.freedesktop.DBus',
get_body => undef,
],
},
{
label => '“Hello†response',
in => "l\2\1\1\x0b\0\0\0\1\0\0\0=\0\0\0\6\1s\0\6\0\0\0:1.174\0\0\5\1u\0\1\0\0\0\10\1g\0\1s\0\0\7\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\6\0\0\0:1.174\0",
methods => [
get_type => Protocol::DBus::Message::Header::MESSAGE_TYPE()->{'METHOD_RETURN'},
[ type_is => 'METHOD_RETURN' ] => 1,
get_flags => 1,
get_serial => 1,
[ get_header => 'DESTINATION'] => ':1.174',
[ get_header => 'REPLY_SERIAL'] => 1,
[ get_header => 'SIGNATURE'] => 's',
[ get_header => 'SENDER'] => 'org.freedesktop.DBus',
get_body => [ ':1.174' ],
]
},
{
label => 'signal',
in => "l\4\1\1\x0b\0\0\0\2\0\0\0\215\0\0\0\1\1o\0\25\0\0\0/org/freedesktop/DBus\0\0\0\2\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\3\1s\0\f\0\0\0NameAcquired\0\0\0\0\6\1s\0\6\0\0\0:1.174\0\0\10\1g\0\1s\0\0\7\1s\0\24\0\0\0org.freedesktop.DBus\0...
methods => [
get_type => Protocol::DBus::Message::Header::MESSAGE_TYPE()->{'SIGNAL'},
[ type_is => 'SIGNAL' ] => 1,
get_flags => 1,
get_serial => 2,
[ get_header => 'PATH'] => '/org/freedesktop/DBus',
[ get_header => 'INTERFACE'] => 'org.freedesktop.DBus',
[ get_header => 'MEMBER'] => 'NameAcquired',
[ get_header => 'DESTINATION'] => ':1.174',
[ get_header => 'SIGNATURE'] => 's',
[ get_header => 'SENDER'] => 'org.freedesktop.DBus',
get_body => [ ':1.174' ],
],
},
{
label => 'Introspect',
in => "l\1\0\1\0\0\0\0\2\0\0\0\227\0\0\0\1\1o\0\37\0\0\0/org/freedesktop/NetworkManager\0\3\1s\0\n\0\0\0Introspect\0\0\0\0\0\0\2\1s\0#\0\0\0org.freedesktop.DBus.Introspectable\0\0\0\0\0\6\1s\0\36\0\0\0org.freedesktop.NetworkManager\0\0",
methods => [
get_type => Protocol::DBus::Message::Header::MESSAGE_TYPE()->{'METHOD_CALL'},
[ type_is => 'METHOD_CALL' ] => 1,
get_flags => 0,
get_serial => 2,
[ get_header => 'PATH' ] => '/org/freedesktop/NetworkManager',
[ get_header => 'MEMBER' ] => 'Introspect',
[ get_header => 'INTERFACE' ] => 'org.freedesktop.DBus.Introspectable',
[ get_header => 'DESTINATION' ] => 'org.freedesktop.NetworkManager',
get_body => undef,
],
},
{
label => '“GetAll†response',
in => "l\2\1\1\251\0\0\0\3\0\0\0E\0\0\0\6\1s\0\6\0\0\0:1.179\0\0\5\1u\0\2\0\0\0\10\1g\0\5a{sv}\0\0\0\0\0\0\7\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0\241\0\0\0\0\0\0\0\10\0\0\0Features\0\2as\0\0\0\0&\0\0\0\10\0\0\0AppArmor\0\0\0\0\21\0\0\0Sy...
methods => [
[ type_is => 'METHOD_RETURN' ] => 1,
[ flags_have => 'NO_REPLY_EXPECTED' ] => 1,
[ get_header => 'DESTINATION' ] => ':1.179',
[ get_header =>'REPLY_SERIAL'] => 2,
[ get_header =>'SIGNATURE'] => 'a{sv}',
[ get_header =>'SENDER'] => 'org.freedesktop.DBus',
get_body => [
all(
Isa('Protocol::DBus::Type::Dict'),
noclass( {
Features => all(
Isa('Protocol::DBus::Type::Array'),
noclass( [
'AppArmor',
'SystemdActivation',
] ),
),
Interfaces => all(
Isa('Protocol::DBus::Type::Array'),
noclass( [
'org.freedesktop.DBus.Monitoring',
'org.freedesktop.DBus.Debug.Stats',
] ),
),
} ),
),
],
],
},
{
label => 'error',
in => "l\3\1\1S\0\0\0\3\0\0\0u\0\0\0\6\1s\0\6\0\0\0:1.123\0\0\4\1s\0)\0\0\0org.freedesktop.DBus.Error.ServiceUnknown\0\0\0\0\0\0\0\5\1u\0\2\0\0\0\10\1g\0\1s\0\0\7\1s\0\24\0\0\0org.freedesktop.DBus\0\0\0\0N\0\0\0The name org.freedesktop.Networ...
methods => [
[ type_is => 'ERROR' ] => 1,
[ flags_have => 'NO_REPLY_EXPECTED' ] => 1,
[ get_header => 'DESTINATION' ] => ':1.123',
[ get_header => 'ERROR_NAME' ] => 'org.freedesktop.DBus.Error.ServiceUnknown',
[ get_header => 'REPLY_SERIAL' ] => 2,
[ get_header => 'SIGNATURE' ] => 's',
[ get_header => 'SENDER' ] => 'org.freedesktop.DBus',
get_body => [
'The name org.freedesktop.NetworkManager was not provided by any .service files',
],
],
},
# TODO: Add more interesting tests.
{
label => 'IP6Config - 1',
in => "l\4\1\1\334\7\0\0B\16\0\0\256\0\0\0\b\1g\0\5a{sv}\0\0\0\0\0\0\1\1o\0,\0\0\0/org/freedesktop/NetworkManager/IP6Config/11\0\0\0\0\3\1s\0\21\0\0\0PropertiesChanged\0\0\0\0\0\0\0\2\1s\0(\0\0\0org.freedesktop.NetworkManager.IP6Config\0\0\0\...
methods => [
[ type_is => 'SIGNAL' ] => 1,
],
},
# TODO: Add more interesting tests.
{
label => 'IP6Config - 2',
in => "l\4\1\1\20\b\0\0W\16\0\0\236\0\0\0\b\1g\0\bsa{sv}as\0\0\0\1\1o\0,\0\0\0/org/freedesktop/NetworkManager/IP6Config/11\0\0\0\0\3\1s\0\21\0\0\0PropertiesChanged\0\0\0\0\0\0\0\2\1s\0\37\0\0\0org.freedesktop.DBus.Properties\0\a\1s\0\5\0\0\0:...
methods => [
[ type_is => 'SIGNAL' ] => 1,
],
},
);
for my $t (@parse_le) {
my $in_copy = $t->{'in'};
my $msg = Protocol::DBus::Message->parse( \$in_copy );
t/integration.t view on Meta::CPAN
# system socket is hard-coded in libdbus at compile time.
#
# It’s still a useful diagnostic, though.
#----------------------------------------------------------------------
my $dbus_send = File::Which::which('dbus-send');
diag( "dbus-send: " . ($dbus_send || '(none)') );
if ($dbus_send) {
system($dbus_send, '--type=method_call', '--system', '--dest=org.freedesktop.DBus', '/org/freedesktop/DBus', 'org.freedesktop.DBus.Properties.GetAll', 'string:org.freedesktop.DBus');
diag( "dbus-send --system worked? " . ($? ? 'no' : 'yes') );
}
my $client = eval {
local $SIG{'__WARN__'} = sub { diag shift() };
my $db = Protocol::DBus::Client::system();
$db->initialize();
$db;
( run in 1.083 second using v1.01-cache-2.11-cpan-299005ec8e3 )