1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
#!/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__
|
