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 <d...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits