# -*- perl -*-
use Test::More tests => 7;
use strict;
use warnings;
BEGIN {
use_ok('Net::DBus::Binding::Introspector');
use_ok('Net::DBus::Object');
};
package MyObject;
use base qw(Net::DBus::Object);
use Net::DBus::Exporter qw(org.example.MyObject);
dbus_method("test_set_serial", ["serial"]);
dbus_method("test_set_caller", ["caller"]);
sub test_set_serial {
my $self = shift;
$self->{serial} = shift;
}
sub test_get_serial {
my $self = shift;
return $self->{serial};
}
sub test_set_caller {
my $self = shift;
$self->{caller} = shift;
}
sub test_get_caller {
my $self = shift;
return $self->{caller};
}
package main;
my $bus = Net::DBus->test;
my $service = $bus->export_service("/org/cpan/Net/Bus/test");
my $object = MyObject->new($service, "/org/example/MyObject");
my $introspector = $object->_introspector;
my $xml_got = $introspector->format();
my $xml_expect = <<EOF;
<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
<node name="/org/example/MyObject">
<interface name="org.example.MyObject">
<method name="test_set_caller">
</method>
<method name="test_set_serial">
</method>
</interface>
<interface name="org.freedesktop.DBus.Introspectable">
<method name="Introspect">
<arg type="s" direction="out"/>
</method>
</interface>
<interface name="org.freedesktop.DBus.Properties">
<method name="Get">
<arg type="s" direction="in"/>
<arg type="s" direction="in"/>
<arg type="v" direction="out"/>
</method>
<method name="Set">
<arg type="s" direction="in"/>
<arg type="s" direction="in"/>
<arg type="v" direction="in"/>
</method>
</interface>
</node>
EOF
is($xml_got, $xml_expect, "xml data matches");
CALLER: {
my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.example.MyObject",
method_name => "test_set_caller");
$msg->set_sender(":1.1");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
is($object->test_get_caller, ":1.1", "caller is :1.1");
}
SERIAL: {
my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
object_path => "/org/example/MyObject",
interface => "org.example.MyObject",
method_name => "test_set_serial");
my $reply = $bus->get_connection->send_with_reply_and_block($msg);
isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
is($object->test_get_serial, $msg->get_serial, "serial matches");
}