#!/usr/bin/perl -w
# -*- perl -*-
#
# $Id: $
# Author: Slaven Rezic
#
use strict;
use Tk;
use Data::Dumper;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
unless ($Tk::platform eq 'unix') {
plan skip_all => 'property only work on X11';
exit 0;
}
plan tests => 38;
my $mw = tkinit;
$mw->geometry("+10+10");
{
my @prop = $mw->property('list');
# Here a test used to check if @prop is empty. But KDE defines a
# _KDE_NET_WM_USER_CREATION_TIME property, so the test cannot be
# used anymore.
pass("property list call on windows");
ok(!$mw->property('exists','_PERL_TK_ThisPropertyDoesNotExist'), "Not-existent property");
}
{
my @prop = $mw->property('list','root');
cmp_ok(scalar(@prop), ">=", 1, "It's very likely that there are properties on the root window");
ok(!$mw->property('exists','_PERL_TK_ThisPropertyDoesNotExist'.rand(10),'root'), "Not-existent property");
}
# format=8 differs from format=16/32: The value to set and get is a
# string. If getting the property value, then a "\0" is appended (I
# don't know if this is intentional, this may change). With
# format=16/32 the values are array references with integers.
{
my $format = 8;
$mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, "a");
ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists");
is($mw->property('get', '_PERL_TK_TestProperty_1'), "a\0", "Expected get result")
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
is_xprop('_PERL_TK_TestProperty_1', [map { ord } split //, "a\0"], "Expected xprop result");
$mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, "abc");
ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists, longer value");
is($mw->property('get', '_PERL_TK_TestProperty_1'), "abc\0")
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
is_xprop('_PERL_TK_TestProperty_1', [map { ord } split //, "abc\0"]);
my @list = $mw->property('list');
ok((grep { $_ eq '_PERL_TK_TestProperty_1' } @list), "Found test property in list");
my @list2 = $mw->property('list', hex $mw->id);
is_deeply(\@list, \@list2, "Same list with explicite window id");
$mw->property('delete', '_PERL_TK_TestProperty_1');
ok(!$mw->property('exists', '_PERL_TK_TestProperty_1'), "Property deleted");
my @list_after_delete = $mw->property('list');
ok(!(grep { $_ eq '_PERL_TK_TestProperty_1' } @list_after_delete), "Not appearing in list anymore");
}
for my $format (16, 32) {
$mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, [1]);
ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists");
is_deeply([$mw->property('get', '_PERL_TK_TestProperty_1')], ["CARDINAL", 1], "Expected get result")
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
is_xprop('_PERL_TK_TestProperty_1', [1], "Expected xprop result");
$mw->property('set', '_PERL_TK_TestProperty_1', "CARDINAL", $format, [1,2,3]);
ok($mw->property('exists', '_PERL_TK_TestProperty_1'), "Format=$format, Property exists, longer value");
is_deeply([$mw->property('get', '_PERL_TK_TestProperty_1')], ["CARDINAL", 1,2,3])
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_1')]);
is_xprop('_PERL_TK_TestProperty_1', [1,2,3]);
$mw->property('delete', '_PERL_TK_TestProperty_1');
ok(!$mw->property('exists', '_PERL_TK_TestProperty_1'), "Property deleted");
}
# Test with ATOMs
{
$mw->property('set', '_PERL_TK_TestProperty_2', "ATOM", 32, ['_PERL_TK_TestAtom_1']);
ok($mw->property('exists', '_PERL_TK_TestProperty_2'), "Property with ATOM exists");
is_deeply([$mw->property('get', '_PERL_TK_TestProperty_2')], ['ATOM', '_PERL_TK_TestAtom_1'], "Expected get result")
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_2')]);
is_xprop('_PERL_TK_TestProperty_2', ['_PERL_TK_TestAtom_1'], "Expected xprop result");
my @list = $mw->property('list');
ok((grep { $_ eq '_PERL_TK_TestProperty_2' } @list), "Found test property in list");
$mw->property('delete', '_PERL_TK_TestProperty_2');
ok(!$mw->property('exists', '_PERL_TK_TestProperty_2'), "Property deleted");
}
# Test with STRINGs
{
$mw->property('set', '_PERL_TK_TestProperty_3', "STRING", 8, 'TestString');
ok($mw->property('exists', '_PERL_TK_TestProperty_3'), "Property with STRING exists");
is($mw->property('get', '_PERL_TK_TestProperty_3'), "TestString\0", "Expected get result")
or diag(Dumper [$mw->property('get', '_PERL_TK_TestProperty_3')]);
is_xprop('_PERL_TK_TestProperty_3', ['"TestString"'], "Expected xprop result");
my @list = $mw->property('list');
ok((grep { $_ eq '_PERL_TK_TestProperty_3' } @list), "Found test property in list");
$mw->property('delete', '_PERL_TK_TestProperty_3');
ok(!$mw->property('exists', '_PERL_TK_TestProperty_3'), "Property deleted");
}
sub is_xprop {
my($prop, $expected, $testname) = @_;
SKIP: {
skip("xprop not in PATH", 1)
if !xprop_is_in_path();
my $mw_id = $mw->id;
chomp(my $res = `xprop -notype -id $mw_id $prop`);
$res =~ s{^\Q$prop\E\s*=\s*}{};
my(@bytes) = split /\s*,\s*/, $res;
is_deeply(\@bytes, $expected, $testname)
or diag(Dumper \@bytes);
}
}
{
my $xprop_is_in_path;
sub xprop_is_in_path {
my($prog) = "xprop";
my $path = eval {
require File::Spec;
require Config;
return $prog if (File::Spec->file_name_is_absolute($prog) and -f $prog and -x $prog);
my $sep = $Config::Config{'path_sep'} || ':';
foreach (split(/$sep/o, $ENV{PATH})) {
return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog");
}
undef;
};
warn $@ if $@; # unlikely to happen
$xprop_is_in_path = $path; # cache
$path;
}
}
__END__