1 files changed, 123 insertions, 0 deletions
diff --git a/dcopperl/test.pl b/dcopperl/test.pl
new file mode 100644
index 00000000..0402395e
--- /dev/null
+++ b/dcopperl/test.pl
@@ -0,0 +1,123 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+        print <<EOT;
+Now that you've built the DCOP extension, it's time to run some tests on it.
+The first of them will just run by themselves, after that, there will be
+some interactive ones.
+
+EOT
+print "Loading...";
+}
+
+END {print "failed\n" unless $loaded;}
+use DCOP;
+$loaded = 1;
+print "done\n";
+
+######################### End of black magic.
+
+my $ok;
+
+sub check {
+        my $res = shift;
+        print $res ? "." : "!";
+        $ok = undef unless $res;
+}
+
+my ($client, $desk);
+
+sub attach {
+        $client = new DCOP;
+        check (ref $client) eq "DCOP";
+        check !$client->isAttached();
+        check $client->attach();
+        check $client->isAttached();
+        check $client->detach();
+        check !$client->isAttached();
+# For now, as register is disabled
+        $client->attach();
+}
+
+sub register {
+        check (my $appid = $client->registerAs("perltests"));
+        print "[$appid]";
+        check $client->isRegistered();
+        check $client->appId() eq $appid;
+        check ($appid = $client->registerAs("perltests", undef));
+        print "[$appid]";
+        check $client->isRegistered();
+        check $client->appId() eq $appid;
+}
+
+sub query {
+        check (my $list = $client->registeredApplications());
+        print "[$#$list]";
+        check ($list = $client->remoteObjects("kdesktop"));
+        print "[$#$list]";
+        check ($list = $client->remoteInterfaces("kdesktop", "qt"));
+        print "[$#$list]";
+        check ($list = $client->remoteFunctions("kdesktop", "qt"));
+        print "[$#$list]";
+        check grep /^QCStringList functions\(\)$/, @$list;
+}
+
+sub calls {
+        check (my $list = $client->call("kdesktop", "qt", "objects()"));
+        print "[$#$list]";
+        check grep m#^qt/kdesktop$#, @$list;
+}
+
+sub magic {
+        check ($desk = $client->createObject("kdesktop"));
+        check (ref $desk) eq "DCOP::Object";
+        check (my ($list) = $desk->interfaces());
+        print "[$#$list]";
+        check grep /^KDesktopIface$/, @$list;
+}
+
+sub icons {
+        check scalar $desk->selectAll();
+        sleep 1;
+        check scalar $desk->unselectAll();
+}
+
+sub saver {
+        check ($desk = $client->createObject("kdesktop")) unless defined $desk;
+        check (my ($saver) = $desk->screenSaver());
+        check (ref $saver) eq "DCOP::Object";
+        check scalar $saver->save();
+}
+
+@tests = (
+        ["simple attachments", \&attach],
+#        ["full registration", \&register],
+        ["tree queries", \&query],
+        ["calls", \&calls],
+        ["autoload magic", \&magic],
+        ["more autoload magic", \&icons,
+         "The next test should cause all icons on your desktop to be selected\nand deselected again."],
+        ["DCOPRefs", \&saver,
+         "The next test should activate your screen saver."],
+        );
+
+foreach (@tests) {
+        my ($msg, $test, $confirm) = @{$_};
+        if ($confirm) {
+                print "$confirm\nDo you want this test to be performed? [Y/n]";
+                my $answer = <>;
+                next unless ($answer =~ /^\s*$/ || $answer =~ /^[yY]/);
+        }
+        printf "%-25s", $msg;
+        $ok = 1;
+        &$test();
+        unless ($ok) {
+                print "failed\n";
+                exit 1;
+        }
+        print "passed\n";
+}
+