[libnet-dbus-perl] 02/335: New set of test cases
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:09 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 37629772fcb9bcf8371fe221b363f18403d7e6ef
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Aug 9 21:42:49 2004 +0000
New set of test cases
---
t/{1.t => 00-constants.t} | 12 -----
t/{6.t => 15-message.t} | 55 +++++++++++-----------
t/2.t | 24 ----------
t/20-callback.t | 65 ++++++++++++++++++++++++++
t/25-reactor.t | 117 ++++++++++++++++++++++++++++++++++++++++++++++
t/3.t | 24 ----------
t/30-server.t | 38 +++++++++++++++
t/4.t | 21 ---------
t/5.t | 39 ----------------
9 files changed, 247 insertions(+), 148 deletions(-)
diff --git a/t/1.t b/t/00-constants.t
similarity index 69%
rename from t/1.t
rename to t/00-constants.t
index e9f79bc..c41863d 100644
--- a/t/1.t
+++ b/t/00-constants.t
@@ -1,10 +1,3 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl 1.t'
-
-#########################
-
-# change 'tests => 6' to 'tests => last_test_to_print';
-
use Test::More tests => 6;
BEGIN {
use_ok('DBus::Watch');
@@ -45,8 +38,3 @@ foreach my $constname (qw(
}
ok( $fail == 0 , 'DBus::Watch Constants' );
-#########################
-
-# Insert your test code below, the Test::More module is use()ed here so read
-# its man page ( perldoc Test::More ) for help writing this test script.
-
diff --git a/t/6.t b/t/15-message.t
similarity index 52%
rename from t/6.t
rename to t/15-message.t
index 2d6a667..623d2fb 100644
--- a/t/6.t
+++ b/t/15-message.t
@@ -1,19 +1,13 @@
-use Test::More tests => 5;
+use Test::More tests => 21;
BEGIN {
- use_ok('DBus');
- use_ok('DBus::Connection');
+ use_ok('DBus::Iterator');
use_ok('DBus::Message::Signal');
- use_ok('DBus::Reactor');
+ use_ok('DBus::Message::MethodCall');
+ use_ok('DBus::Message::MethodReturn');
+ use_ok('DBus::Message::Error');
};
-my $con = DBus::Connection->new(address => "unix:path=/tmp/dbus-perl-test");
-#my $con = DBus::Bus->new(type => DBus::DBUS_BUS_SYSTEM);
-
-ok($con, "Connection");
-
-ok($con->is_connected, "Is Connected");
-
my $msg = DBus::Message::Signal->new(path => "/foo/bar/Wizz",
interface => "com.blah.Example",
name => "Eeek");
@@ -23,8 +17,13 @@ $iter->append_boolean(1);
$iter->append_byte(43);
$iter->append_int32(123);
$iter->append_uint32(456);
-$iter->append_int64(12345645645);
-$iter->append_uint64(12312312312);
+if ($DBus::Iterator::have_quads) {
+ $iter->append_int64(12345645645);
+ $iter->append_uint64(12312312312);
+} else {
+ $iter->append_boolean(1);
+ $iter->append_boolean(1);
+}
$iter->append_string("Hello world");
$iter->append_double(1.424141);
@@ -33,26 +32,26 @@ ok($iter->get_boolean() == 1, "boolean");
ok($iter->next(), "next");
ok($iter->get_byte() == 43, "byte");
ok($iter->next(), "next");
+
ok($iter->get_int32() == 123, "int32");
ok($iter->next(), "next");
ok($iter->get_uint32() == 456, "uint32");
ok($iter->next(), "next");
-ok($iter->get_int64() == 12345645645, "int64");
-ok($iter->next(), "next");
-ok($iter->get_uint64() == 12312312312, "uint64");
-ok($iter->next(), "next");
+
+if (!$DBus::Iterator::have_quads) {
+ ok(1, "int64 skipped");
+ ok($iter->next(), "next");
+ ok(1, "uint64 skipped");
+ ok($iter->next(), "next");
+} else {
+ ok($iter->get_int64() == 12345645645, "int64");
+ ok($iter->next(), "next");
+ ok($iter->get_uint64() == 12312312312, "uint64");
+ ok($iter->next(), "next");
+}
+
ok($iter->get_string() eq "Hello world", "string");
ok($iter->next(), "next");
ok($iter->get_double() == 1.424141, "double");
+ok(!$iter->next(), "next");
-my $reactor = DBus::Reactor->new();
-$reactor->manage($con);
-ok(1, "watches");
-
-$con->send($msg);
-
-$reactor->run();
-
-$con->disconnect;
-
-ok(!$con->is_connected, "Not Connected");
diff --git a/t/2.t b/t/2.t
deleted file mode 100644
index f2e106a..0000000
--- a/t/2.t
+++ /dev/null
@@ -1,24 +0,0 @@
-
-use Test::More tests => 4;
-BEGIN { use_ok('DBus::Connection');
- use_ok('DBus::Reactor');
- };
-
-$ENV{DBUS_VERBOSE} = 1;
-
-#my $con = DBus::Connection->new(address => "unix:path=/var/run/dbus/system_bus_socket");
-my $con = DBus::Connection->new(address => "unix:path=/tmp/dbus-perl-test");
-
-ok($con, "Connection");
-
-ok($con->is_connected, "Is Connected");
-
-my $reactor = DBus::Reactor->new();
-$reactor->manage($con);
-ok(1, "watches");
-
-$reactor->run();
-
-$con->disconnect;
-
-ok(!$con->is_connected, "Not Connected");
diff --git a/t/20-callback.t b/t/20-callback.t
new file mode 100644
index 0000000..3fefa8e
--- /dev/null
+++ b/t/20-callback.t
@@ -0,0 +1,65 @@
+use Test::More tests => 5;
+
+BEGIN {
+ use_ok('DBus::Callback');
+};
+
+my $doneit = 0;
+
+my $doer = Doer->new;
+
+my $callback = DBus::Callback->new(
+ object => $doer,
+ method => "doit",
+ args => [4, 3, 5]
+ );
+
+$callback->invoke();
+ok($doer->doneit == 12, "object callback");
+
+$callback->invoke();
+ok($doer->doneit == 24, "object callback");
+
+$callback = DBus::Callback->new(
+ method => \&doit,
+ args => [5,1,2]
+ );
+
+$callback->invoke();
+ok($doneit == 8, "subroutine callback");
+
+$callback->invoke();
+ok($doneit == 16, "subroutine callback");
+
+sub doit {
+ foreach (@_) {
+ $doneit += $_;
+ }
+}
+
+package Doer;
+
+
+sub new {
+ my $class = shift;
+ my $self = {};
+
+ $self->{doneit} = 0;
+
+ bless $self, $class;
+
+ return $self;
+}
+
+sub doit {
+ my $self = shift;
+
+ foreach (@_) {
+ $self->{doneit} += $_;
+ }
+}
+
+sub doneit {
+ my $self = shift;
+ return $self->{doneit};
+}
diff --git a/t/25-reactor.t b/t/25-reactor.t
new file mode 100644
index 0000000..53369e5
--- /dev/null
+++ b/t/25-reactor.t
@@ -0,0 +1,117 @@
+use Test::More tests => 16;
+use POSIX qw(pipe read write);
+use strict;
+use warnings;
+
+# The tests for timeouts will only work
+# reliably on unloaded machine
+
+BEGIN {
+ use_ok('DBus::Reactor');
+ use_ok('DBus::Callback');
+};
+
+
+my $reactor = DBus::Reactor->new();
+
+my $started = $reactor->_now;
+my $fired;
+my $alarmed;
+
+my $tid = $reactor->add_timeout(2000,
+ DBus::Callback->new(method => \&timeout, args => []),
+ 1);
+
+$SIG{ALRM} = sub { $alarmed = 1 };
+
+# Alarm just in case something goes horribly wrong
+alarm 3;
+$reactor->run;
+alarm 0;
+
+ok (!$alarmed, "not alarmed");
+ok (defined $fired, "timeout fired");
+
+# Timing is tricky, so just check a reasonble range
+ok(($fired-$started) > 1900 &&
+ ($fired-$started) < 2100, "timeout in range 900->1100");
+
+sub timeout {
+ $fired = $reactor->_now;
+ $reactor->shutdown;
+}
+
+$reactor->remove_timeout($tid);
+
+my ($r1, $w1) = pipe;
+my ($r2, $w2) = pipe;
+
+write $w1, "1", 1;
+
+my ($r1c, $w1c, $r2c, $w2c) = (0,0,0,0);
+my $hookc = 0;
+
+$reactor->add_read($r1,
+ DBus::Callback->new(method => \&do_r1));
+$reactor->add_write($w1,
+ DBus::Callback->new(method => \&do_w1),
+ 0);
+$reactor->add_read($r2,
+ DBus::Callback->new(method => \&do_r2));
+$reactor->add_write($w2,
+ DBus::Callback->new(method => \&do_w2),
+ 0);
+
+$reactor->add_hook(DBus::Callback->new(method => \&hook));
+
+$reactor->step;
+
+ok($r1c == 1, "read one byte a");
+ok($r2c == 0, "not read one byte b");
+ok($hookc == 1, "hook 1\n");
+
+write $w1, "11", 2;
+write $w2, "1", 1;
+
+$reactor->step;
+
+ok($r1c == 2, "read 2 byte a");
+ok($r2c == 1, "read one byte b");
+ok($hookc == 2, "hook 2\n");
+
+$reactor->step;
+
+ok($r1c == 3, "read 2 byte a");
+ok($hookc == 3, "hook 3\n");
+
+$reactor->toggle_write($w1, 1);
+$reactor->toggle_write($w2, 1);
+
+$reactor->step;
+
+ok($w1c == 1, "write 1 byte a");
+ok($w2c == 1, "write 1 byte b");
+ok($hookc == 4, "hook 4\n");
+
+
+sub do_r1 {
+ my $buf;
+ $r1c += read $r1, $buf, 1;
+}
+
+sub do_w1 {
+ $w1c += write $w1, "1", 1;
+}
+
+sub do_r2 {
+ my $buf;
+ $r2c += read $r2, $buf, 1;
+}
+
+sub do_w2 {
+ $w2c += write $w2, "1", 1;
+}
+
+sub hook {
+ $hookc++;
+}
diff --git a/t/3.t b/t/3.t
deleted file mode 100644
index ee47541..0000000
--- a/t/3.t
+++ /dev/null
@@ -1,24 +0,0 @@
-use Test::More tests => 5;
-BEGIN {
- use_ok('DBus');
- use_ok('DBus::Bus');
- use_ok('DBus::Reactor');
- };
-
-
-my $con = DBus::Bus->new(type => &DBus::Bus::SYSTEM);
-
-ok($con, "Connection");
-
-ok($con->is_connected, "Is Connected");
-
-my $reactor = DBus::Reactor->new();
-$reactor->manage($con);
-ok(1, "watches");
-
-$reactor->run();
-
-$con->disconnect;
-
-ok(!$con->is_connected, "Not Connected");
-
diff --git a/t/30-server.t b/t/30-server.t
new file mode 100644
index 0000000..5969068
--- /dev/null
+++ b/t/30-server.t
@@ -0,0 +1,38 @@
+use Test::More tests => 11;
+BEGIN {
+ use_ok('DBus::Server');
+ use_ok('DBus::Connection');
+ use_ok('DBus::Reactor');
+ use_ok('DBus::Message::Signal');
+}
+
+
+my $server = DBus::Server->new(address => "unix:path=/tmp/dbus-perl-test-$$");
+ok ($server->is_connected, "server connected");
+
+my $reactor = DBus::Reactor->new();
+$reactor->manage($server);
+
+my $incoming;
+$server->set_connection_callback(sub {
+ $incoming = shift;
+});
+
+my $client = DBus::Connection->new(address => "unix:path=/tmp/dbus-perl-test-$$");
+ok ($client->is_connected, "client connected");
+$reactor->manage($client);
+
+$reactor->step;
+
+ok (defined $incoming, "incoming");
+ok ($incoming->is_connected, "incoming connected");
+$reactor->manage($incoming);
+
+$client->disconnect;
+ok (!$client->is_connected, "client disconnected");
+
+$incoming->disconnect;
+ok (!$incoming->is_connected, "incoming disconnected");
+
+$server->disconnect;
+ok (!$server->is_connected, "server disconnected");
diff --git a/t/4.t b/t/4.t
deleted file mode 100644
index 1f05129..0000000
--- a/t/4.t
+++ /dev/null
@@ -1,21 +0,0 @@
-use Test::More tests => 7;
-BEGIN {
- use_ok('DBus::Bus');
- use_ok('DBus::Message::Signal');
- use_ok('DBus::Message::MethodCall');
- };
-
-
-my $con = DBus::Bus->new(type => &DBus::Bus::SYSTEM);
-
-ok($con, "Connection");
-
-my $signal = DBus::Message::Signal->new(path => "foo/bar", interface => "bar.wizz", name => "wizz");
-
-my $serial = $con->send($signal);
-
-ok($serial, "serial");
-
-$con->flush();
-
-ok(1, "flush");
diff --git a/t/5.t b/t/5.t
deleted file mode 100644
index 73005d2..0000000
--- a/t/5.t
+++ /dev/null
@@ -1,39 +0,0 @@
-use Test::More tests => 5;
-BEGIN { use_ok('DBus::Server'); use_ok('DBus'); use_ok('DBus::Reactor') };
-
-$ENV{DBUS_VERBOSE} = 1;
-
-my $con = DBus::Server->new(address => "unix:path=/tmp/dbus-perl-test");
-
-ok($con, "Server");
-
-ok($con->is_connected, "Is Connected");
-
-$con->set_connection_callback(\&new_con);
-
-my $reactor = DBus::Reactor->new();
-
-$reactor->manage($con);
-
-ok(1, "watches");
-
-$reactor->run();
-
-
-$con->disconnect;
-
-ok(!$con->is_connected, "Not Connected");
-
-my %cons;
-
-sub new_con {
- my $server = shift;
- my $connection = shift;
-
- $cons{$connection} = $connection;
-
- $reactor->manage($connection);
-
- print "Got $server $connection\n";
-}
-
--
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