tdebindings/dcopperl/test.pl

# 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";
}