[libnet-dbus-perl] 162/335: Significantly increase test coverage & adapt existing tests to use mock objects
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:46 UTC 2015
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.
commit 31cc735da09c27db45ff5477d5d957c2d905945b
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Nov 21 11:43:51 2005 +0000
Significantly increase test coverage & adapt existing tests to use mock objects
---
t/40-introspector.t | 18 +-
t/45-exporter.t | 109 +++++++
t/50-object-introspect.t | 22 +-
t/55-method-calls.t | 174 ++++++++++
t/56-scalar-param-typing.t | 783 +++++++++++++++++++++++++++++++++++++++++++++
t/60-object-props.t | 180 +++--------
t/65-object-magic.t | 85 +----
7 files changed, 1139 insertions(+), 232 deletions(-)
diff --git a/t/40-introspector.t b/t/40-introspector.t
index 57fa95e..0a64cb9 100644
--- a/t/40-introspector.t
+++ b/t/40-introspector.t
@@ -25,12 +25,14 @@ TEST_ONE: {
},
},
signals => {
- "meltdown" => ["int32", "byte"],
+ "meltdown" => {
+ params => ["int32", "byte"],
+ }
},
props => {
- "name" => ["string", "readwrite"],
- "email" => ["string", "read"],
- "age" => ["int32", "read"],
+ "name" => { type => "string", access => "readwrite"},
+ "email" => { type => "string", access => "read"},
+ "age" => { type => "int32", access => "read"},
},
}
});
@@ -82,7 +84,9 @@ EOF
},
},
signals => {
- "meltdown" => ["int32", "byte"],
+ "meltdown" => {
+ params => ["int32", "byte"],
+ }
},
},
"org.example.OtherInterface" => {
@@ -93,8 +97,8 @@ EOF
}
},
props => {
- "title" => ["string", "readwrite"],
- "salary" => ["int32", "read"],
+ "title" => { type => "string", access => "readwrite"},
+ "salary" => { type => "int32", access => "read"},
},
},
},
diff --git a/t/45-exporter.t b/t/45-exporter.t
new file mode 100644
index 0000000..6c3b8f4
--- /dev/null
+++ b/t/45-exporter.t
@@ -0,0 +1,109 @@
+# -*- perl -*-
+
+use Test::More tests => 93;
+
+package MyObject1;
+
+use Test::More;
+use base qw(Net::DBus::Object);
+use Net::DBus;
+use Net::DBus::Service;
+
+use Net::DBus::Exporter qw(org.example.MyObject);
+
+my $bus = Net::DBus->test;
+my $service = $bus->export_service("org.example.MyService");
+my $obj = MyObject1->new($service, "/org/example/MyObject");
+
+# First the full APIs
+dbus_method("Everything", ["string"], ["int32"]);
+dbus_method("EverythingInterface", ["string"], ["int32"], "org.example.OtherObject");
+
+# Now add in annotations to the mix
+dbus_method("EverythingAnnotate", ["string"], ["int32"], { deprecated => 1,
+ no_return => 1 });
+dbus_method("EverythingNegativeAnnotate", ["string"], ["int32"], { deprecated => 0,
+ no_return => 0 });
+dbus_method("EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 1,
+ no_return => 1 });
+dbus_method("EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 0,
+ no_return => 0 });
+
+# Now test 'defaults'
+dbus_method("NoArgsReturns");
+dbus_method("NoReturns", ["string"]);
+dbus_method("NoArgs",[],["int32"]);
+dbus_method("NoArgsReturnsInterface", "org.example.OtherObject");
+dbus_method("NoReturnsInterface", ["string"], "org.example.OtherObject");
+dbus_method("NoArgsInterface", [],["int32"], "org.example.OtherObject");
+
+dbus_method("NoArgsReturnsAnnotate", { deprecated => 1 });
+dbus_method("NoReturnsAnnotate", ["string"], { deprecated => 1 });
+dbus_method("NoArgsAnnotate",[],["int32"], { deprecated => 1 });
+dbus_method("NoArgsReturnsInterfaceAnnotate", "org.example.OtherObject", { deprecated => 1 });
+dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1 });
+dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject", { deprecated => 1 });
+
+
+
+my $ins = Net::DBus::Exporter::dbus_introspector($obj);
+
+is($ins->get_object_path, "/org/example/MyObject", "object path");
+ok($ins->has_interface("org.example.MyObject"), "interface registration");
+ok(!$ins->has_interface("org.example.BogusObject"), "-ve interface registration");
+
+&check_method($ins, "Everything", ["string"], ["int32"], "org.example.MyObject", 0, 0);
+&check_method($ins, "EverythingInterface", ["string"], ["int32"], "org.example.OtherObject", 0, 0);
+&check_method($ins, "EverythingAnnotate", ["string"], ["int32"], "org.example.MyObject", 1, 1);
+&check_method($ins, "EverythingNegativeAnnotate", ["string"], ["int32"], "org.example.MyObject", 0, 0);
+&check_method($ins, "EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", 1, 1);
+&check_method($ins, "EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", 0, 0);
+
+&check_method($ins, "NoArgsReturns", [], [], "org.example.MyObject", 0, 0);
+&check_method($ins, "NoReturns", ["string"], [], "org.example.MyObject", 0, 0);
+&check_method($ins, "NoArgs", [], ["int32"], "org.example.MyObject", 0, 0);
+&check_method($ins, "NoArgsReturnsInterface", [], [], "org.example.OtherObject", 0, 0);
+&check_method($ins, "NoReturnsInterface", ["string"], [], "org.example.OtherObject", 0, 0);
+&check_method($ins, "NoArgsInterface", [], ["int32"], "org.example.OtherObject", 0, 0);
+
+&check_method($ins, "NoArgsReturnsAnnotate", [], [], "org.example.MyObject", 1, 0);
+&check_method($ins, "NoReturnsAnnotate", ["string"], [], "org.example.MyObject", 1, 0);
+&check_method($ins, "NoArgsAnnotate", [], ["int32"], "org.example.MyObject", 1, 0);
+&check_method($ins, "NoArgsReturnsInterfaceAnnotate", [], [], "org.example.OtherObject", 1, 0);
+&check_method($ins, "NoReturnsInterfaceAnnotate", ["string"], [], "org.example.OtherObject", 1, 0);
+&check_method($ins, "NoArgsInterfaceAnnotate", [], ["int32"], "org.example.OtherObject", 1, 0);
+
+
+sub check_method {
+ my $ins = shift;
+ my $name = shift;
+ my $params = shift;
+ my $returns = shift;
+ my $interface = shift;
+ my $deprecated = shift;
+ my $no_return = shift;
+
+ my @interfaces = $ins->has_method($name);
+ is_deeply([$interface], \@interfaces, "method interface mapping");
+
+ my @params = $ins->get_method_params($interface, $name);
+ is_deeply($params, \@params, "method parameters");
+
+ my @returns = $ins->get_method_returns($interface, $name);
+ is_deeply($returns, \@returns, "method returneters");
+
+ if ($deprecated) {
+ ok($ins->is_method_deprecated($name, $interface), "method deprecated");
+ } else {
+ ok(!$ins->is_method_deprecated($name, $interface), "method deprecated");
+ }
+
+
+ if ($no_return) {
+ ok(!$ins->does_method_reply($name, $interface), "method no reply");
+ } else {
+ ok($ins->does_method_reply($name, $interface), "method no reply");
+ }
+
+
+}
diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t
index 8d15c76..906ed65 100644
--- a/t/50-object-introspect.t
+++ b/t/50-object-introspect.t
@@ -9,7 +9,10 @@ BEGIN {
use_ok('Net::DBus::Object');
};
-my $object = Net::DBus::Object->new(new DummyService(), "/org/example/Object/OtherObject");
+my $bus = Net::DBus->test;
+my $service = $bus->export_service("/org/cpan/Net/DBus/Test/introspect");
+
+my $object = Net::DBus::Object->new($service, "/org/example/Object/OtherObject");
my $introspector = $object->_introspector;
@@ -39,20 +42,5 @@ my $xml_expect = <<EOF;
</node>
EOF
- is($xml_got, $xml_expect, "xml data matches");
-
-
-package DummyService;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- bless $self, $class;
-
- return $self;
-}
+is($xml_got, $xml_expect, "xml data matches");
-sub _register_object {
- my $self = shift;
-}
diff --git a/t/55-method-calls.t b/t/55-method-calls.t
new file mode 100644
index 0000000..7e3e450
--- /dev/null
+++ b/t/55-method-calls.t
@@ -0,0 +1,174 @@
+# -*- perl -*-
+
+use Test::More tests => 67;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Binding::Introspector') or die;
+ use_ok('Net::DBus::Object') or die;
+ use_ok('Net::DBus::Test::MockObject') or die;
+};
+
+
+TEST_NO_INTROSPECT: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
+ error => { name => "org.freedesktop.DBus.Error.Failed",
+ description => "No such method" });
+
+ &test_method_fail("raw, no introspect", $robject, "Test");
+ &test_method_reply("myobject, no introspect",$myobject, "Test", "TestedMyObject");
+ &test_method_fail("otherobject, no introspect",$otherobject, "Test");
+
+ &test_method_fail("raw, no introspect",$robject, "Bogus");
+ &test_method_fail("myobject, no introspect",$myobject, "Bogus");
+ &test_method_fail("otherobject, no introspect",$otherobject, "Bogus");
+
+ &test_method_fail("raw, no introspect",$robject, "PolyTest");
+ &test_method_reply("myobject, no introspect",$myobject, "PolyTest", "PolyTestedMyObject");
+ &test_method_reply("otherobject, no introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");
+
+ &test_method_fail("raw, no introspect", $robject, "Deprecated");
+ &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
+ &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
+
+ &test_method_fail("raw, no introspect", $robject, "TestNoReturn");
+ &test_method_fail("myobject, no introspect",$myobject, "TestNoReturn");
+ &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
+}
+
+TEST_MISSING_INTROSPECT: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
+ $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
+ reply => { return => [ $ins->format ] });
+
+
+ &test_method_fail("raw, missing introspect",$robject, "Test");
+ &test_method_reply("myobject, missing introspect",$myobject, "Test", "TestedMyObject");
+ &test_method_fail("otherobject, missing introspect",$otherobject, "Test");
+
+ &test_method_fail("raw, missing introspect",$robject, "Bogus");
+ &test_method_fail("myobject, missing introspect",$myobject, "Bogus");
+ &test_method_fail("otherobject, missing introspect",$otherobject, "Bogus");
+
+ &test_method_fail("raw, missing introspect",$robject, "PolyTest");
+ &test_method_reply("myobject, missing introspect",$myobject, "PolyTest", "PolyTestedMyObject");
+ &test_method_reply("otherobject, missing introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");
+
+ &test_method_fail("raw, no introspect", $robject, "Deprecated");
+ &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
+ &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
+
+ &test_method_fail("raw, no introspect", $robject, "TestNoReturn");
+ &test_method_fail("myobject, no introspect",$myobject, "TestNoReturn");
+ &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
+}
+
+TEST_FULL_INTROSPECT: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
+ $ins->add_method("Test", [], ["string"], "org.example.MyObject");
+ $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject");
+ $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject");
+ $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 });
+ $ins->add_method("TestNoReturn", [], [], "org.example.MyObject", { no_return => 1 });
+ $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
+ reply => { return => [ $ins->format ] });
+
+
+ &test_method_reply("raw, full introspect",$robject, "Test", "TestedMyObject");
+ &test_method_reply("myobject, full introspect",$myobject, "Test", "TestedMyObject");
+ &test_method_fail("otherobject, full introspect",$otherobject, "Test");
+
+ &test_method_fail("raw, full introspect",$robject, "Bogus");
+ &test_method_fail("myobject, full introspect",$myobject, "Bogus");
+ &test_method_fail("otherobject, full introspect",$otherobject, "Bogus");
+
+ &test_method_fail("raw, full introspect",$robject, "PolyTest");
+ &test_method_reply("myobject, full introspect",$myobject, "PolyTest", "PolyTestedMyObject");
+ &test_method_reply("otherobject, full introspect",$otherobject, "PolyTest", "PolyTestedOtherObject");
+
+ {
+ my $warned = 0;
+ local $SIG{__WARN__} = sub {
+ if ($_[0] eq "method 'Deprecated' in interface org.example.MyObject on object /org/example/MyObject is deprecated\n") {
+ $warned = 1;
+ }
+ };
+ &test_method_reply("raw, no introspect", $robject, "Deprecated", "TestedDeprecation");
+ ok($warned, "deprecation warning generated");
+ $warned = 0;
+ &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation");
+ ok($warned, "deprecation warning generated");
+ $warned = 0;
+ &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated");
+ ok(!$warned, "deprecation warning generated");
+ }
+
+ &test_method_noreply("raw, no introspect", $robject, "TestNoReturn");
+ &test_method_noreply("myobject, no introspect",$myobject, "TestNoReturn");
+ &test_method_fail("otherobject, no introspect",$otherobject, "TestNoReturn");
+}
+
+
+sub setup {
+ my $bus = Net::DBus->test;
+ my $service = $bus->export_service("org.cpan.Net.Bus.test");
+
+ my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject");
+
+ my $rservice = $bus->get_service("org.cpan.Net.Bus.test");
+ my $robject = $rservice->get_object("/org/example/MyObject");
+ my $myobject = $robject->as_interface("org.example.MyObject");
+ my $otherobject = $robject->as_interface("org.example.OtherObject");
+
+ $object->seed_action("org.example.MyObject", "Test", reply => { return => [ "TestedMyObject" ] });
+ $object->seed_action("org.example.MyObject", "PolyTest", reply => { return => [ "PolyTestedMyObject" ] });
+ $object->seed_action("org.example.OtherObject", "PolyTest", reply => { return => [ "PolyTestedOtherObject" ] });
+ $object->seed_action("org.example.MyObject", "Deprecated", reply => { return => [ "TestedDeprecation" ]});
+ $object->seed_action("org.example.MyObject", "TestNoReturn");
+
+ return ($bus, $object, $robject, $myobject, $otherobject);
+}
+
+sub test_method_noreply {
+ my $tag = shift;
+ my $object = shift;
+ my $method = shift;
+
+ my $actual = eval {
+ $object->$method;
+ };
+ is($@, "", "error is not thrown by '$method' ($tag)");
+ ok(!$actual, "return from '$method' is undefined ($tag)");
+}
+
+sub test_method_reply {
+ my $tag = shift;
+ my $object = shift;
+ my $method = shift;
+ my $expect = shift;
+
+ my $actual = eval {
+ $object->$method;
+ };
+ is($@, "", "error is not thrown by '$method' ($tag)");
+ is($actual, $expect, "return from '$method' is '$actual' ($tag)");
+}
+
+sub test_method_fail {
+ my $tag = shift;
+ my $object = shift;
+ my $method = shift;
+
+ my $actual = eval {
+ $object->$method;
+ };
+ ok($@, "error is thrown by '$method' ($tag)");
+}
diff --git a/t/56-scalar-param-typing.t b/t/56-scalar-param-typing.t
new file mode 100644
index 0000000..187ddf2
--- /dev/null
+++ b/t/56-scalar-param-typing.t
@@ -0,0 +1,783 @@
+# -*- perl -*-
+
+use Test::More tests => 256;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Binding::Introspector') or die;
+ use_ok('Net::DBus::Object') or die;
+ use_ok('Net::DBus::Test::MockObject') or die;
+ use_ok("Net::DBus", qw(:typing)) or die;
+};
+
+TEST_NO_INTROSPECT: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ ##### String tests
+
+ $myobject->ScalarString("Foo");
+ is($object->get_last_message_signature, "s", "string as string");
+ is($object->get_last_message_param, "Foo", "string as string");
+
+ $myobject->ScalarString(2);
+ is($object->get_last_message->get_signature, "s", "int as string");
+ is($object->get_last_message_param, "2", "int as string");
+
+ $myobject->ScalarString(5.234);
+ is($object->get_last_message->get_signature, "s", "double as string");
+ is($object->get_last_message_param, "5.234", "double as string");
+
+
+ #### INT 32 tests
+
+ # Positive integers
+ $myobject->ScalarInt32("2");
+ is($object->get_last_message_signature, "s", "string as int32");
+ is($object->get_last_message_param, "2", "string as int32");
+
+ $myobject->ScalarInt32(2);
+ is($object->get_last_message_signature, "s", "int as int32");
+ is($object->get_last_message_param, "2", "int as int32");
+
+ $myobject->ScalarInt32(2.0);
+ is($object->get_last_message_signature, "s", "double as int32");
+ is($object->get_last_message_param, "2", "double as int32");
+
+ # Negative integers
+ $myobject->ScalarInt32("-2");
+ is($object->get_last_message_signature, "s", "-ve string as int32");
+ is($object->get_last_message_param, "-2", "-ve string as int32");
+
+ $myobject->ScalarInt32(-2);
+ is($object->get_last_message_signature, "s", "-ve int as int32");
+ is($object->get_last_message_param, "-2", "-ve int as int32");
+
+ $myobject->ScalarInt32(-2.0);
+ is($object->get_last_message_signature, "s", "-ve double as int32");
+ is($object->get_last_message_param, "-2", "-ve double as int32");
+
+ # Rounding of doubles
+ $myobject->ScalarInt32(2.1);
+ is($object->get_last_message_signature, "s", "round down double as int32");
+ is($object->get_last_message_param, "2.1", "round down double as int32");
+
+ $myobject->ScalarInt32(2.9);
+ is($object->get_last_message_signature, "s", "round up double as int32");
+ is($object->get_last_message_param, "2.9", "round up double as int32");
+
+ $myobject->ScalarInt32(2.5);
+ is($object->get_last_message_signature, "s", "round up double threshold as int32");
+ is($object->get_last_message_param, "2.5", "round up double threshold as int32");
+
+ $myobject->ScalarInt32(-2.1);
+ is($object->get_last_message_signature, "s", "-ve round up double as int32");
+ is($object->get_last_message_param, "-2.1", "-ve round up double as int32");
+
+ $myobject->ScalarInt32(-2.9);
+ is($object->get_last_message_signature, "s", "-ve round down double as int32");
+ is($object->get_last_message_param, "-2.9", "-ve round down double as int32");
+
+ $myobject->ScalarInt32(-2.5);
+ is($object->get_last_message_signature, "s", "-ve round down double threshold as int32");
+ is($object->get_last_message_param, "-2.5", "-ve round down double threshold as int32");
+
+
+ #### UINT 32 tests
+
+ # Positive integers
+ $myobject->ScalarUInt32("2");
+ is($object->get_last_message_signature, "s", "string as uint32");
+ is($object->get_last_message_param, "2", "string as uint32");
+
+ $myobject->ScalarUInt32(2);
+ is($object->get_last_message_signature, "s", "int as uint32");
+ is($object->get_last_message_param, "2", "int as uint32");
+
+ $myobject->ScalarUInt32(2.0);
+ is($object->get_last_message_signature, "s", "double as uint32");
+ is($object->get_last_message_param, "2", "double as uint32");
+
+ # Negative integers
+ $myobject->ScalarUInt32("-2");
+ is($object->get_last_message_signature, "s", "-ve string as uint32");
+ is($object->get_last_message_param, "-2", "-ve string as uint32");
+
+ $myobject->ScalarUInt32(-2);
+ is($object->get_last_message_signature, "s", "-ve int as uint32");
+ is($object->get_last_message_param, "-2", "-ve int as uint32");
+
+ $myobject->ScalarUInt32(-2.0);
+ is($object->get_last_message_signature, "s", "-ve double as uint32");
+ is($object->get_last_message_param, "-2", "-ve double as uint32");
+
+
+ # Rounding of doubles
+ $myobject->ScalarUInt32(2.1);
+ is($object->get_last_message_signature, "s", "round down double as uint32");
+ is($object->get_last_message_param, "2.1", "round down double as uint32");
+
+ $myobject->ScalarUInt32(2.9);
+ is($object->get_last_message_signature, "s", "round up double as uint32");
+ is($object->get_last_message_param, "2.9", "round up double as uint32");
+
+ $myobject->ScalarUInt32(2.5);
+ is($object->get_last_message_signature, "s", "round up double threshold as uint32");
+ is($object->get_last_message_param, "2.5", "round up double threshold as uint32");
+
+
+ #### Double tests
+
+ # Double
+ $myobject->ScalarDouble(5.234);
+ is($object->get_last_message_signature, "s", "double as double");
+ is($object->get_last_message_param, "5.234", "double as double");
+
+ # Stringized Double
+ $myobject->ScalarDouble("2.1");
+ is($object->get_last_message_signature, "s", "string as double");
+ is($object->get_last_message_param, "2.1", "string as double");
+
+ # Integer -> double conversion
+ $myobject->ScalarDouble(2);
+ is($object->get_last_message_signature, "s", "int as double");
+ is($object->get_last_message_param, "2", "int as double");
+
+
+ # -ve Double
+ $myobject->ScalarDouble(-5.234);
+ is($object->get_last_message_signature, "s", "-ve double as double");
+ is($object->get_last_message_param, "-5.234", "-ve double as double");
+
+ # -ve Stringized Double
+ $myobject->ScalarDouble("-2.1");
+ is($object->get_last_message_signature, "s", "-ve string as double");
+ is($object->get_last_message_param, "-2.1", "-ve string as double");
+
+ # -ve Integer -> double conversion
+ $myobject->ScalarDouble(-2);
+ is($object->get_last_message_signature, "s", "-ve int as double");
+ is($object->get_last_message_param, "-2", "-ve int as double");
+
+
+ #### Byte tests
+
+ # Int
+ $myobject->ScalarByte(7);
+ is($object->get_last_message_signature, "s", "int as byte");
+ is($object->get_last_message_param, "7", "int as byte");
+
+ # Double roudning
+ $myobject->ScalarByte(2.6);
+ is($object->get_last_message_signature, "s", "double as byte");
+ is($object->get_last_message_param, "2.6", "double as byte");
+
+ # Range overflow
+ $myobject->ScalarByte(10000);
+ is($object->get_last_message_signature, "s", "int as byte overflow");
+ is($object->get_last_message_param, "10000", "int as byte overflow");
+
+
+ # -ve Int
+ $myobject->ScalarByte(-7);
+ is($object->get_last_message_signature, "s", "-ve int as byte");
+ is($object->get_last_message_param, "-7", "-ve int as byte");
+
+ # -ve Double roudning
+ $myobject->ScalarByte(-2.6);
+ is($object->get_last_message_signature, "s", "double as byte");
+ is($object->get_last_message_param, "-2.6", "double as byte");
+
+ # -ve Range overflow
+ $myobject->ScalarByte(-10000);
+ is($object->get_last_message_signature, "s", "-ve int as byte overflow");
+ is($object->get_last_message_param, "-10000", "-ve int as byte overflow");
+
+
+ ##### Boolean
+
+ # String, O and false
+ $myobject->ScalarBoolean("0");
+ is($object->get_last_message_signature, "s", "string as boolean, 0 and false");
+ is($object->get_last_message_param, "0", "string as boolean, 0 and false");
+
+ # String, O but true
+ $myobject->ScalarBoolean("0true");
+ is($object->get_last_message_signature, "s", "string as boolean, 0 but true");
+ is($object->get_last_message_param, "0true", "string as boolean, 0 but true");
+
+ # String, 1 and true
+ $myobject->ScalarBoolean("1true");
+ is($object->get_last_message_signature, "s", "string as boolean, 1 and true");
+ is($object->get_last_message_param, "1true", "string as boolean, 1 and true");
+
+ # Int true
+ $myobject->ScalarBoolean(1);
+ is($object->get_last_message_signature, "s", "int as boolean, true");
+ is($object->get_last_message_param, "1", "int as boolean, true");
+
+ # Int false
+ $myobject->ScalarBoolean(0);
+ is($object->get_last_message_signature, "s", "int as boolean, false");
+ is($object->get_last_message_param, "0", "int as boolean, false");
+
+ # Undefined and false
+ $myobject->ScalarBoolean(undef);
+ is($object->get_last_message_signature, "s", "undefined as boolean, false");
+ is($object->get_last_message_param, "", "undefined as boolean, false");
+
+}
+
+
+
+TEST_MANUAL_TYPING: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ ##### String tests
+
+ $myobject->ScalarString("Foo");
+ is($object->get_last_message_signature, "s", "string as string");
+ is($object->get_last_message_param, "Foo", "string as string");
+
+ $myobject->ScalarString(2);
+ is($object->get_last_message->get_signature, "s", "int as string");
+ is($object->get_last_message_param, "2", "int as string");
+
+ $myobject->ScalarString(5.234);
+ is($object->get_last_message->get_signature, "s", "double as string");
+ is($object->get_last_message_param, "5.234", "double as string");
+
+
+ #### INT 32 tests
+
+ # Positive integers
+ $myobject->ScalarInt32(dbus_int32("2"));
+ is($object->get_last_message_signature, "i", "string as int32");
+ is($object->get_last_message_param, 2, "string as int32");
+
+ $myobject->ScalarInt32(dbus_int32(2));
+ is($object->get_last_message_signature, "i", "int as int32");
+ is($object->get_last_message_param, 2, "int as int32");
+
+ $myobject->ScalarInt32(dbus_int32(2.0));
+ is($object->get_last_message_signature, "i", "double as int32");
+ is($object->get_last_message_param, 2, "double as int32");
+
+ # Negative integers
+ $myobject->ScalarInt32(dbus_int32("-2"));
+ is($object->get_last_message_signature, "i", "-ve string as int32");
+ is($object->get_last_message_param, -2, "-ve string as int32");
+
+ $myobject->ScalarInt32(dbus_int32(-2));
+ is($object->get_last_message_signature, "i", "-ve int as int32");
+ is($object->get_last_message_param, -2, "-ve int as int32");
+
+ $myobject->ScalarInt32(dbus_int32(-2.0));
+ is($object->get_last_message_signature, "i", "-ve double as int32");
+ is($object->get_last_message_param, -2, "-ve double as int32");
+
+ # Rounding of doubles
+ $myobject->ScalarInt32(dbus_int32(2.1));
+ is($object->get_last_message_signature, "i", "round down double as int32");
+ is($object->get_last_message_param, 2, "round down double as int32");
+
+ $myobject->ScalarInt32(dbus_int32(2.9));
+ is($object->get_last_message_signature, "i", "round up double as int32");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double as int32");
+ }
+ $myobject->ScalarInt32(dbus_int32(2.5));
+ is($object->get_last_message_signature, "i", "round up double threshold as int32");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double threshold as int32");
+ }
+
+ $myobject->ScalarInt32(dbus_int32(-2.1));
+ is($object->get_last_message_signature, "i", "-ve round up double as int32");
+ is($object->get_last_message_param, -2, "-ve round up double as int32");
+
+ $myobject->ScalarInt32(dbus_int32(-2.9));
+ is($object->get_last_message_signature, "i", "-ve round down double as int32");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, -3, "-ve round down double as int32");
+ }
+
+ $myobject->ScalarInt32(dbus_int32(-2.5));
+ is($object->get_last_message_signature, "i", "-ve round down double threshold as int32");
+ is($object->get_last_message_param, -2, "-ve round down double threshold as int32");
+
+
+ #### UINT 32 tests
+
+ # Positive integers
+ $myobject->ScalarUInt32(dbus_uint32("2"));
+ is($object->get_last_message_signature, "u", "string as uint32");
+ is($object->get_last_message_param, 2, "string as uint32");
+
+ $myobject->ScalarUInt32(dbus_uint32(2));
+ is($object->get_last_message_signature, "u", "int as uint32");
+ is($object->get_last_message_param, 2, "int as uint32");
+
+ $myobject->ScalarUInt32(dbus_uint32(2.0));
+ is($object->get_last_message_signature, "u", "double as uint32");
+ is($object->get_last_message_param, 2, "double as uint32");
+
+ # Negative integers
+ $myobject->ScalarUInt32(dbus_uint32("-2"));
+ is($object->get_last_message_signature, "u", "-ve string as uint32");
+ SKIP: {
+ skip "sign truncation is wrong", 1;
+ is($object->get_last_message_param, -2, "-ve string as uint32");
+ }
+
+ $myobject->ScalarUInt32(dbus_uint32(-2));
+ is($object->get_last_message_signature, "u", "-ve int as uint32");
+ SKIP: {
+ skip "sign truncation is wrong", 1;
+ is($object->get_last_message_param, -2, "-ve int as uint32");
+ }
+
+ $myobject->ScalarUInt32(dbus_uint32(-2.0));
+ is($object->get_last_message_signature, "u", "-ve double as uint32");
+ SKIP: {
+ skip "sign truncation is wrong", 1;
+ is($object->get_last_message_param, -2, "-ve double as uint32");
+ }
+
+ # Rounding of doubles
+ $myobject->ScalarUInt32(dbus_uint32(2.1));
+ is($object->get_last_message_signature, "u", "round down double as uint32");
+ is($object->get_last_message_param, 2, "round down double as uint32");
+
+ $myobject->ScalarUInt32(dbus_uint32(2.9));
+ is($object->get_last_message_signature, "u", "round up double as uint32");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double as uint32");
+ }
+
+ $myobject->ScalarUInt32(dbus_uint32(2.5));
+ is($object->get_last_message_signature, "u", "round up double threshold as uint32");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double threshold as uint32");
+ }
+
+ #### Double tests
+
+ # Double
+ $myobject->ScalarDouble(dbus_double(5.234));
+ is($object->get_last_message_signature, "d", "double as double");
+ is($object->get_last_message_param, 5.234, "double as double");
+
+ # Stringized Double
+ $myobject->ScalarDouble(dbus_double("2.1"));
+ is($object->get_last_message_signature, "d", "string as double");
+ is($object->get_last_message_param, 2.1, "string as double");
+
+ # Integer -> double conversion
+ $myobject->ScalarDouble(dbus_double(2));
+ is($object->get_last_message_signature, "d", "int as double");
+ is($object->get_last_message_param, 2.0, "int as double");
+
+
+ # -ve Double
+ $myobject->ScalarDouble(dbus_double(-5.234));
+ is($object->get_last_message_signature, "d", "-ve double as double");
+ is($object->get_last_message_param, -5.234, "-ve double as double");
+
+ # -ve Stringized Double
+ $myobject->ScalarDouble(dbus_double("-2.1"));
+ is($object->get_last_message_signature, "d", "-ve string as double");
+ is($object->get_last_message_param, -2.1, "-ve string as double");
+
+ # -ve Integer -> double conversion
+ $myobject->ScalarDouble(dbus_double(-2));
+ is($object->get_last_message_signature, "d", "-ve int as double");
+ is($object->get_last_message_param, -2.0, "-ve int as double");
+
+
+ #### Byte tests
+
+ # Int
+ $myobject->ScalarByte(dbus_byte(7));
+ is($object->get_last_message_signature, "y", "int as byte");
+ is($object->get_last_message_param, 7, "int as byte");
+
+ # Double roudning
+ $myobject->ScalarByte(dbus_byte(2.6));
+ is($object->get_last_message_signature, "y", "double as byte");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "double as byte");
+ }
+
+ # Range overflow
+ $myobject->ScalarByte(dbus_byte(10000));
+ is($object->get_last_message_signature, "y", "int as byte overflow");
+ SKIP: {
+ skip "rounding actually truncates", 1;
+ is($object->get_last_message_param, 10000, "int as byte overflow");
+ }
+
+ # -ve Int
+ $myobject->ScalarByte(dbus_byte(-7));
+ is($object->get_last_message_signature, "y", "-ve int as byte");
+ SKIP: {
+ skip "sign truncation broken", 1;
+ is($object->get_last_message_param, -7, "-ve int as byte");
+ }
+
+ # -ve Double roudning
+ $myobject->ScalarByte(dbus_byte(-2.6));
+ is($object->get_last_message_signature, "y", "double as byte");
+ SKIP: {
+ skip "sign truncation broken", 1;
+ is($object->get_last_message_param, -3, "double as byte");
+ }
+
+ # -ve Range overflow
+ $myobject->ScalarByte(dbus_byte(-10000));
+ is($object->get_last_message_signature, "y", "-ve int as byte overflow");
+ SKIP: {
+ skip "sign truncation broken", 1;
+ is($object->get_last_message_param, -10000, "-ve int as byte overflow");
+ }
+
+ ##### Boolean
+
+ # String, O and false
+ $myobject->ScalarBoolean(dbus_boolean("0"));
+ is($object->get_last_message_signature, "b", "string as boolean, 0 and false");
+ is($object->get_last_message_param, '', "string as boolean, 0 and false");
+
+ # String, O but true
+ $myobject->ScalarBoolean(dbus_boolean("0true"));
+ is($object->get_last_message_signature, "b", "string as boolean, 0 but true");
+ is($object->get_last_message_param, '1', "string as boolean, 0 but true");
+
+ # String, 1 and true
+ $myobject->ScalarBoolean(dbus_boolean("1true"));
+ is($object->get_last_message_signature, "b", "string as boolean, 1 and true");
+ is($object->get_last_message_param, '1', "string as boolean, 1 and true");
+
+ # Int true
+ $myobject->ScalarBoolean(dbus_boolean(1));
+ is($object->get_last_message_signature, "b", "int as boolean, true");
+ is($object->get_last_message_param, '1', "int as boolean, true");
+
+ # Int false
+ $myobject->ScalarBoolean(dbus_boolean(0));
+ is($object->get_last_message_signature, "b", "int as boolean, false");
+ is($object->get_last_message_param, '', "int as boolean, false");
+
+ # Undefined and false
+ $myobject->ScalarBoolean(dbus_boolean(undef));
+ is($object->get_last_message_signature, "b", "undefined as boolean, false");
+ is($object->get_last_message_param, '', "undefined as boolean, false");
+
+}
+
+
+
+TEST_INTROSPECT_TYPING: {
+ my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
+
+ my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
+ $ins->add_method("ScalarString", ["string"], [], "org.example.MyObject");
+ $ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject");
+ $ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject");
+ $ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject");
+ $ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject");
+ $ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject");
+ $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
+ reply => { return => [ $ins->format ] });
+
+ ##### String tests
+
+ $myobject->ScalarString("Foo");
+ is($object->get_last_message_signature, "s", "string as string");
+ is($object->get_last_message_param, "Foo", "string as string");
+
+ $myobject->ScalarString(2);
+ is($object->get_last_message->get_signature, "s", "int as string");
+ is($object->get_last_message_param, "2", "int as string");
+
+ $myobject->ScalarString(5.234);
+ is($object->get_last_message->get_signature, "s", "double as string");
+ is($object->get_last_message_param, "5.234", "double as string");
+
+
+ #### INT 32 tests
+
+ # Positive integers
+ $myobject->ScalarInt32("2");
+ is($object->get_last_message_signature, "i", "string as int32");
+ is($object->get_last_message_param, 2, "string as int32");
+
+ $myobject->ScalarInt32(2);
+ is($object->get_last_message_signature, "i", "int as int32");
+ is($object->get_last_message_param, 2, "int as int32");
+
+ $myobject->ScalarInt32(2.0);
+ is($object->get_last_message_signature, "i", "double as int32");
+ is($object->get_last_message_param, 2, "double as int32");
+
+ # Negative integers
+ $myobject->ScalarInt32("-2");
+ is($object->get_last_message_signature, "i", "-ve string as int32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, "-2", "-ve string as int32");
+ }
+
+ $myobject->ScalarInt32(-2);
+ is($object->get_last_message_signature, "i", "-ve int as int32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, "-2", "-ve int as int32");
+ }
+
+ $myobject->ScalarInt32(-2.0);
+ is($object->get_last_message_signature, "i", "-ve double as int32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, "-2.0", "-ve double as int32");
+ }
+
+ # Rounding of doubles
+ $myobject->ScalarInt32(2.1);
+ is($object->get_last_message_signature, "i", "round down double as int32");
+ is($object->get_last_message_param, 2, "round down double as int32");
+
+ $myobject->ScalarInt32(2.9);
+ is($object->get_last_message_signature, "i", "round up double as int32");
+ SKIP: {
+ skip "double -> int rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double as int32");
+ }
+
+ $myobject->ScalarInt32(2.5);
+ is($object->get_last_message_signature, "i", "round up double threshold as int32");
+ SKIP: {
+ skip "double -> int rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double threshold as int32");
+ }
+
+ $myobject->ScalarInt32(-2.1);
+ is($object->get_last_message_signature, "i", "-ve round up double as int32");
+ is($object->get_last_message_param, -2, "-ve round up double as int32");
+
+ $myobject->ScalarInt32(-2.9);
+ is($object->get_last_message_signature, "i", "-ve round down double as int32");
+ SKIP: {
+ skip "double -> int rounding actually truncates", 1;
+ is($object->get_last_message_param, -3, "-ve round down double as int32");
+ }
+
+ $myobject->ScalarInt32(-2.5);
+ is($object->get_last_message_signature, "i", "-ve round down double threshold as int32");
+ is($object->get_last_message_param, -2, "-ve round down double threshold as int32");
+
+
+ #### UINT 32 tests
+
+ # Positive integers
+ $myobject->ScalarUInt32("2");
+ is($object->get_last_message_signature, "u", "string as uint32");
+ is($object->get_last_message_param, 2, "string as uint32");
+
+ $myobject->ScalarUInt32(2);
+ is($object->get_last_message_signature, "u", "int as uint32");
+ is($object->get_last_message_param, 2, "int as uint32");
+
+ $myobject->ScalarUInt32(2.0);
+ is($object->get_last_message_signature, "u", "double as uint32");
+ is($object->get_last_message_param, 2, "double as uint32");
+
+ # Negative integers
+ $myobject->ScalarUInt32("-2");
+ is($object->get_last_message_signature, "u", "-ve string as uint32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, -2, "-ve string as uint32");
+ }
+
+ $myobject->ScalarUInt32(-2);
+ is($object->get_last_message_signature, "u", "-ve int as uint32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, -2, "-ve int as uint32");
+ }
+
+ $myobject->ScalarUInt32(-2.0);
+ is($object->get_last_message_signature, "u", "-ve double as uint32");
+ SKIP: {
+ skip "sign truncation not checked", 1;
+ is($object->get_last_message_param, -2, "-ve double as uint32");
+ }
+
+
+ # Rounding of doubles
+ $myobject->ScalarUInt32(2.1);
+ is($object->get_last_message_signature, "u", "round down double as uint32");
+ is($object->get_last_message_param, 2, "round down double as uint32");
+
+ $myobject->ScalarUInt32(2.9);
+ is($object->get_last_message_signature, "u", "round up double as uint32");
+ SKIP: {
+ skip "double -> int rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double as uint32");
+ }
+
+ $myobject->ScalarUInt32(2.5);
+ is($object->get_last_message_signature, "u", "round up double threshold as uint32");
+ SKIP: {
+ skip "double -> int rounding actually truncates", 1;
+ is($object->get_last_message_param, 3, "round up double threshold as uint32");
+ }
+
+ #### Double tests
+
+ # Double
+ $myobject->ScalarDouble(5.234);
+ is($object->get_last_message_signature, "d", "double as double");
+ is($object->get_last_message_param, 5.234, "double as double");
+
+ # Stringized Double
+ $myobject->ScalarDouble("2.1");
+ is($object->get_last_message_signature, "d", "string as double");
+ is($object->get_last_message_param, 2.1, "string as double");
+
+ # Integer -> double conversion
+ $myobject->ScalarDouble(2);
+ is($object->get_last_message_signature, "d", "int as double");
+ is($object->get_last_message_param, 2.0, "int as double");
+
+
+ # -ve Double
+ $myobject->ScalarDouble(-5.234);
+ is($object->get_last_message_signature, "d", "-ve double as double");
+ is($object->get_last_message_param, -5.234, "-ve double as double");
+
+ # -ve Stringized Double
+ $myobject->ScalarDouble("-2.1");
+ is($object->get_last_message_signature, "d", "-ve string as double");
+ is($object->get_last_message_param, -2.1, "-ve string as double");
+
+ # -ve Integer -> double conversion
+ $myobject->ScalarDouble(-2);
+ is($object->get_last_message_signature, "d", "-ve int as double");
+ is($object->get_last_message_param, -2.0, "-ve int as double");
+
+
+ #### Byte tests
+
+ # Int
+ $myobject->ScalarByte(7);
+ is($object->get_last_message_signature, "y", "int as byte");
+ is($object->get_last_message_param, 7, "int as byte");
+
+ # Double roudning
+ $myobject->ScalarByte(2.6);
+ is($object->get_last_message_signature, "y", "double as byte");
+ SKIP: {
+ skip "double rounding not sorted", 1;
+ is($object->get_last_message_param, 3, "double as byte");
+ }
+
+ # Range overflow
+ $myobject->ScalarByte(10000);
+ is($object->get_last_message_signature, "y", "int as byte overflow");
+ SKIP: {
+ skip "byte overflow not checked", 1;
+ is($object->get_last_message_param, 2, "int as byte overflow");
+ }
+
+
+ # -ve Int
+ $myobject->ScalarByte(-7);
+ is($object->get_last_message_signature, "y", "-ve int as byte");
+ SKIP: {
+ skip "byte sign truncation not double checked", 1;
+ is($object->get_last_message_param, 2, "-ve int as byte");
+ }
+
+ # -ve Double roudning
+ $myobject->ScalarByte(-2.6);
+ is($object->get_last_message_signature, "y", "double as byte");
+ SKIP: {
+ skip "byte sign truncation not double checked", 1;
+ is($object->get_last_message_param, 2, "-ve double as byte");
+ }
+
+ # -ve Range overflow
+ $myobject->ScalarByte(-10000);
+ is($object->get_last_message_signature, "y", "-ve int as byte overflow");
+ SKIP: {
+ skip "byte sign truncation not double checked", 1;
+ is($object->get_last_message_param, 2, "-ve int as byte overflow");
+ }
+
+ ##### Boolean
+
+ # String, O and false
+ $myobject->ScalarBoolean("0");
+ is($object->get_last_message_signature, "b", "string as boolean, 0 and false");
+ is($object->get_last_message_param, '', "string as boolean, 0 and false");
+
+ # String, O but true
+ $myobject->ScalarBoolean("0true");
+ is($object->get_last_message_signature, "b", "string as boolean, 0 but true");
+ is($object->get_last_message_param, 1, "string as boolean, 0 but true");
+
+ # String, 1 and true
+ $myobject->ScalarBoolean("1true");
+ is($object->get_last_message_signature, "b", "string as boolean, 1 and true");
+ is($object->get_last_message_param, 1, "string as boolean, 1 and true");
+
+ # Int true
+ $myobject->ScalarBoolean(1);
+ is($object->get_last_message_signature, "b", "int as boolean, true");
+ is($object->get_last_message_param, 1, "int as boolean, true");
+
+ # Int false
+ $myobject->ScalarBoolean(0);
+ is($object->get_last_message_signature, "b", "int as boolean, false");
+ is($object->get_last_message_param, '', "int as boolean, false");
+
+ # Undefined and false
+ $myobject->ScalarBoolean(undef);
+ is($object->get_last_message_signature, "b", "undefined as boolean, false");
+ is($object->get_last_message_param, '', "undefined as boolean, false");
+
+}
+
+exit 0;
+
+sub setup {
+ my $bus = Net::DBus->test;
+ my $service = $bus->export_service("org.cpan.Net.Bus.test");
+
+ my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject");
+
+ my $rservice = $bus->get_service("org.cpan.Net.Bus.test");
+ my $robject = $rservice->get_object("/org/example/MyObject");
+ my $myobject = $robject->as_interface("org.example.MyObject");
+ my $otherobject = $robject->as_interface("org.example.OtherObject");
+
+ $object->seed_action("org.example.MyObject", "ScalarString", reply => { return => [] });
+ $object->seed_action("org.example.MyObject", "ScalarInt32", reply => { return => [] });
+ $object->seed_action("org.example.MyObject", "ScalarUInt32", reply => { return => [] });
+ $object->seed_action("org.example.MyObject", "ScalarDouble", reply => { return => [] });
+ $object->seed_action("org.example.MyObject", "ScalarByte", reply => { return => [] });
+ $object->seed_action("org.example.MyObject", "ScalarBoolean", reply => { return => [] });
+
+
+ return ($bus, $object, $robject, $myobject, $otherobject);
+}
+
diff --git a/t/60-object-props.t b/t/60-object-props.t
index 04a651c..d812883 100644
--- a/t/60-object-props.t
+++ b/t/60-object-props.t
@@ -42,7 +42,8 @@ dbus_property("age", "int32" ,"write");
package main;
-my $service = new DummyService();
+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;
@@ -92,8 +93,7 @@ GET_NAME: {
$object->name("John Doe");
- $object->_dispatch($service->get_bus->get_connection, $msg);
- my $reply = $service->get_bus->get_connection->next_message;
+ my $reply = $bus->get_connection->send_with_reply_and_block($msg);
isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
@@ -113,10 +113,10 @@ GET_BOGUS: {
$object->name("John Doe");
- $object->_dispatch($service->get_bus->get_connection, $msg);
- my $reply = $service->get_bus->get_connection->next_message;
-
- isa_ok($reply, "Net::DBus::Binding::Message::Error");
+ my $reply = eval {
+ $bus->get_connection->send_with_reply_and_block($msg);
+ };
+ ok($@, "error is set");
}
sub GET_SET_NAME: {
@@ -125,19 +125,18 @@ sub GET_SET_NAME: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
- my $iter = $msg1->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("name");
+ my $iter1 = $msg1->iterator(1);
+ $iter1->append_string("org.example.MyObject");
+ $iter1->append_string("name");
$object->name("John Doe");
- $object->_dispatch($service->get_bus->get_connection, $msg1);
- my $reply = $service->get_bus->get_connection->next_message;
+ my $reply1 = $bus->get_connection->send_with_reply_and_block($msg1);
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ isa_ok($reply1, "Net::DBus::Binding::Message::MethodReturn");
- my ($value) = $reply->get_args_list;
- is($value, "John Doe", "name is John Doe");
+ my ($value1) = $reply1->get_args_list;
+ is($value1, "John Doe", "name is John Doe");
my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
@@ -145,24 +144,22 @@ sub GET_SET_NAME: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
- $iter = $msg2->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("name");
- $iter->append_variant("Jane Doe");
+ my $iter2 = $msg2->iterator(1);
+ $iter2->append_string("org.example.MyObject");
+ $iter2->append_string("name");
+ $iter2->append_variant("Jane Doe");
- $object->_dispatch($service->get_bus->get_connection, $msg2);
- $reply = $service->get_bus->get_connection->next_message;
+ my $reply2 = $bus->get_connection->send_with_reply_and_block($msg2);
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ isa_ok($reply2, "Net::DBus::Binding::Message::MethodReturn");
- $object->_dispatch($service->get_bus->get_connection, $msg1);
- $reply = $service->get_bus->get_connection->next_message;
+ my $reply3 = $bus->get_connection->send_with_reply_and_block($msg1);
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ isa_ok($reply3, "Net::DBus::Binding::Message::MethodReturn");
- ($value) = $reply->get_args_list;
- is($value, "Jane Doe", "name is Jane Doe");
+ my ($value2) = $reply3->get_args_list;
+ is($value2, "Jane Doe", "name is Jane Doe");
}
@@ -172,9 +169,9 @@ SET_AGE: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
- my $iter = $msg1->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("age");
+ my $iter1 = $msg1->iterator(1);
+ $iter1->append_string("org.example.MyObject");
+ $iter1->append_string("age");
my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService",
@@ -182,21 +179,20 @@ SET_AGE: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
- $iter = $msg2->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("age");
- $iter->append_variant(21);
+ my $iter2 = $msg2->iterator(1);
+ $iter2->append_string("org.example.MyObject");
+ $iter2->append_string("age");
+ $iter2->append_variant(21);
- $object->_dispatch($service->get_bus->get_connection, $msg2);
- my $reply = $service->get_bus->get_connection->next_message;
-
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ my $reply1 = $bus->get_connection->send_with_reply_and_block($msg2);
+ isa_ok($reply1, "Net::DBus::Binding::Message::MethodReturn");
- $object->_dispatch($service->get_bus->get_connection, $msg1);
- $reply = $service->get_bus->get_connection->next_message;
- isa_ok($reply, "Net::DBus::Binding::Message::Error");
+ my $reply2 = eval {
+ $bus->get_connection->send_with_reply_and_block($msg1);
+ };
+ ok($@, "error is set");
is($object->age, 21, "age is 21");
}
@@ -208,9 +204,9 @@ GET_EMAIL: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Get");
- my $iter = $msg1->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("email");
+ my $iter1 = $msg1->iterator(1);
+ $iter1->append_string("org.example.MyObject");
+ $iter1->append_string("email");
$object->email('john at example.com');
@@ -219,98 +215,24 @@ GET_EMAIL: {
interface => "org.freedesktop.DBus.Properties",
method_name => "Set");
- $iter = $msg2->iterator(1);
- $iter->append_string("org.example.MyObject");
- $iter->append_string("email");
- $iter->append_variant('jane at example.com');
-
- $object->_dispatch($service->get_bus->get_connection, $msg2);
- my $reply = $service->get_bus->get_connection->next_message;
+ my $iter2 = $msg2->iterator(1);
+ $iter2->append_string("org.example.MyObject");
+ $iter2->append_string("email");
+ $iter2->append_variant('jane at example.com');
- isa_ok($reply, "Net::DBus::Binding::Message::Error");
+ my $reply1 = eval {
+ $bus->get_connection->send_with_reply_and_block($msg2);
+ };
+ ok($@, "error is set");
+ my $reply2 = $bus->get_connection->send_with_reply_and_block($msg1);
- $object->_dispatch($service->get_bus->get_connection, $msg1);
- $reply = $service->get_bus->get_connection->next_message;
-
- isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
+ isa_ok($reply2, "Net::DBus::Binding::Message::MethodReturn");
is($object->age, 21, "age is 21");
- my ($value) = $reply->get_args_list;
+ my ($value) = $reply2->get_args_list;
is($value, 'john at example.com', 'email is john at example.com');
}
-package DummyService;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{bus} = DummyBus->new();
-
- bless $self, $class;
-
- return $self;
-}
-
-sub _register_object {
- my $self = shift;
-}
-
-sub get_bus {
- my $self = shift;
- return $self->{bus};
-}
-
-package DummyBus;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{connection} = DummyConnection->new();
-
- bless $self, $class;
-
- return $self;
-}
-
-sub get_connection {
- my $self = shift;
- return $self->{connection};
-}
-
-
-package DummyConnection;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{msgs} = [];
-
- bless $self, $class;
-
- return $self;
-}
-
-
-sub send {
- my $self = shift;
- my $msg = shift;
-
- push @{$self->{msgs}}, $msg;
-}
-
-sub next_message {
- my $self = shift;
-
- return shift @{$self->{msgs}};
-}
-
-sub register_object_path {
- my $self = shift;
- # nada
-}
diff --git a/t/65-object-magic.t b/t/65-object-magic.t
index 9fdbdb3..660c00d 100644
--- a/t/65-object-magic.t
+++ b/t/65-object-magic.t
@@ -39,7 +39,8 @@ sub test_get_caller {
package main;
-my $service = new DummyService();
+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;
@@ -84,8 +85,8 @@ CALLER: {
interface => "org.example.MyObject",
method_name => "test_set_caller");
$msg->set_sender(":1.1");
- $object->_dispatch($service->get_bus->get_connection, $msg);
- my $reply = $service->get_bus->get_connection->next_message;
+
+ my $reply = $bus->get_connection->send_with_reply_and_block($msg);
isa_ok($reply, "Net::DBus::Binding::Message::MethodReturn");
@@ -98,85 +99,11 @@ SERIAL: {
object_path => "/org/example/MyObject",
interface => "org.example.MyObject",
method_name => "test_set_serial");
- $object->_dispatch($service->get_bus->get_connection, $msg);
- my $reply = $service->get_bus->get_connection->next_message;
+
+ 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");
}
-
-
-package DummyService;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{bus} = DummyBus->new();
-
- bless $self, $class;
-
- return $self;
-}
-
-sub _register_object {
- my $self = shift;
-}
-
-sub get_bus {
- my $self = shift;
- return $self->{bus};
-}
-
-package DummyBus;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{connection} = DummyConnection->new();
-
- bless $self, $class;
-
- return $self;
-}
-
-sub get_connection {
- my $self = shift;
- return $self->{connection};
-}
-
-
-package DummyConnection;
-
-sub new {
- my $class = shift;
- my $self = {};
-
- $self->{msgs} = [];
-
- bless $self, $class;
-
- return $self;
-}
-
-
-sub send {
- my $self = shift;
- my $msg = shift;
-
- push @{$self->{msgs}}, $msg;
-}
-
-sub next_message {
- my $self = shift;
-
- return shift @{$self->{msgs}};
-}
-
-sub register_object_path {
- my $self = shift;
- # nada
-}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list