You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
124 lines
3.4 KiB
124 lines
3.4 KiB
# 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", \®ister],
|
|
["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";
|
|
}
|
|
|