line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright 2011, 2012, 2013, 2014, 2016, 2017, 2018, 2019 Kevin Ryde |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# This file is part of X11-Protocol-Other. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# X11-Protocol-Other is free software; you can redistribute it and/or modify |
6
|
|
|
|
|
|
|
# it under the terms of the GNU General Public License as published by the |
7
|
|
|
|
|
|
|
# Free Software Foundation; either version 3, or (at your option) any later |
8
|
|
|
|
|
|
|
# version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# X11-Protocol-Other is distributed in the hope that it will be useful, but |
11
|
|
|
|
|
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY |
12
|
|
|
|
|
|
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
13
|
|
|
|
|
|
|
# for more details. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License along |
16
|
|
|
|
|
|
|
# with X11-Protocol-Other. If not, see . |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# /usr/share/doc/xorg-docs/icccm/icccm.txt.gz |
20
|
|
|
|
|
|
|
# /usr/share/doc/xorg-docs/ctext/ctext.txt.gz |
21
|
|
|
|
|
|
|
# |
22
|
|
|
|
|
|
|
# /usr/include/X11/Xutil.h |
23
|
|
|
|
|
|
|
# Xlib structs. |
24
|
|
|
|
|
|
|
# |
25
|
|
|
|
|
|
|
# http://www.pps.univ-paris-diderot.fr/%7Ejch/software/UTF8_STRING/ |
26
|
|
|
|
|
|
|
# http://www.pps.univ-paris-diderot.fr/%7Ejch/software/UTF8_STRING/UTF8_STRING.text |
27
|
|
|
|
|
|
|
# /so/netwm/UTF8_STRING.text |
28
|
|
|
|
|
|
|
|
29
|
4
|
|
|
4
|
|
14351
|
BEGIN { require 5 } |
30
|
|
|
|
|
|
|
package X11::Protocol::WM; |
31
|
4
|
|
|
4
|
|
32
|
use strict; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
142
|
|
32
|
4
|
|
|
4
|
|
22
|
use Carp; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
197
|
|
33
|
4
|
|
|
4
|
|
2030
|
use X11::AtomConstants; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
166
|
|
34
|
4
|
|
|
4
|
|
2260
|
use X11::Protocol::Other; |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
181
|
|
35
|
|
|
|
|
|
|
|
36
|
4
|
|
|
4
|
|
27
|
use vars '$VERSION', '@ISA', '@EXPORT_OK'; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
223
|
|
37
|
|
|
|
|
|
|
$VERSION = 31; |
38
|
|
|
|
|
|
|
|
39
|
4
|
|
|
4
|
|
23
|
use Exporter; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
356
|
|
40
|
|
|
|
|
|
|
@ISA = ('Exporter'); |
41
|
|
|
|
|
|
|
@EXPORT_OK = qw( |
42
|
|
|
|
|
|
|
frame_window_to_client |
43
|
|
|
|
|
|
|
root_to_virtual_root |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
change_wm_hints |
46
|
|
|
|
|
|
|
change_net_wm_state |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
get_wm_icon_size |
49
|
|
|
|
|
|
|
get_wm_hints |
50
|
|
|
|
|
|
|
get_wm_state |
51
|
|
|
|
|
|
|
get_net_frame_extents |
52
|
|
|
|
|
|
|
get_net_wm_state |
53
|
|
|
|
|
|
|
set_text_property |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
set_wm_class |
56
|
|
|
|
|
|
|
set_wm_client_machine |
57
|
|
|
|
|
|
|
set_wm_client_machine_from_syshostname |
58
|
|
|
|
|
|
|
set_wm_command |
59
|
|
|
|
|
|
|
set_wm_hints |
60
|
|
|
|
|
|
|
set_wm_name |
61
|
|
|
|
|
|
|
set_wm_normal_hints |
62
|
|
|
|
|
|
|
set_wm_icon_name |
63
|
|
|
|
|
|
|
set_wm_protocols |
64
|
|
|
|
|
|
|
set_wm_transient_for |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
set_motif_wm_hints |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
set_net_wm_pid |
69
|
|
|
|
|
|
|
set_net_wm_state |
70
|
|
|
|
|
|
|
set_net_wm_user_time |
71
|
|
|
|
|
|
|
set_net_wm_window_type |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
pack_wm_hints |
74
|
|
|
|
|
|
|
pack_wm_size_hints |
75
|
|
|
|
|
|
|
pack_motif_wm_hints |
76
|
|
|
|
|
|
|
unpack_wm_hints |
77
|
|
|
|
|
|
|
unpack_wm_state |
78
|
|
|
|
|
|
|
aspect_to_num_den |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
iconify |
81
|
|
|
|
|
|
|
withdraw |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# uncomment this to run the ### lines |
85
|
|
|
|
|
|
|
# use Smart::Comments; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
89
|
|
|
|
|
|
|
# shared bits |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
BEGIN { |
92
|
4
|
50
|
33
|
4
|
|
547
|
eval 'utf8->can("is_utf8") && *is_utf8 = \&utf8::is_utf8' # 5.8.1 |
|
4
|
|
33
|
4
|
|
2255
|
|
|
4
|
|
|
|
|
40799
|
|
|
4
|
|
|
|
|
203
|
|
93
|
|
|
|
|
|
|
|| eval 'use Encode "is_utf8"; 1' # 5.8.0 |
94
|
|
|
|
|
|
|
|| eval 'sub is_utf8 { 0 }; 1' # 5.6 fallback |
95
|
|
|
|
|
|
|
|| die 'Oops, cannot create is_utf8() subr: ',$@; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
### \&is_utf8 |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub set_text_property { |
100
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $prop, $str) = @_; |
101
|
0
|
0
|
|
|
|
|
if (defined $str) { |
102
|
0
|
|
|
|
|
|
my $type; |
103
|
0
|
|
|
|
|
|
($type, $str) = _to_TEXT ($X, $str); |
104
|
0
|
|
|
|
|
|
$X->ChangeProperty ($window, |
105
|
|
|
|
|
|
|
$prop, # prop name |
106
|
|
|
|
|
|
|
$type, # type |
107
|
|
|
|
|
|
|
8, # format |
108
|
|
|
|
|
|
|
'Replace', |
109
|
|
|
|
|
|
|
$str); |
110
|
|
|
|
|
|
|
} else { |
111
|
0
|
|
|
|
|
|
$X->DeleteProperty ($window, $prop); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# Maybe ... |
116
|
|
|
|
|
|
|
# |
117
|
|
|
|
|
|
|
# =item C<$str = _to_STRING ($str)> |
118
|
|
|
|
|
|
|
# |
119
|
|
|
|
|
|
|
# Convert C<$str> to latin-1 bytes for use in a STRING property. If C<$str> |
120
|
|
|
|
|
|
|
# is already bytes then they're presumed to be latin-1. If C<$str> is Perl |
121
|
|
|
|
|
|
|
# 5.8 wide chars then it's converted with the Encode module, and C |
122
|
|
|
|
|
|
|
# if cannot be represented as a STRING. |
123
|
|
|
|
|
|
|
# |
124
|
|
|
|
|
|
|
sub _to_STRING { |
125
|
0
|
|
|
0
|
|
|
my ($str) = @_; |
126
|
0
|
0
|
|
|
|
|
if (is_utf8($str)) { |
127
|
0
|
|
|
|
|
|
require Encode; |
128
|
|
|
|
|
|
|
# croak in the interests of not letting bad values go through unnoticed, |
129
|
|
|
|
|
|
|
# nor letting a mangled name be stored |
130
|
0
|
|
|
|
|
|
return Encode::encode ('iso-8859-1', $str, Encode::FB_CROAK()); |
131
|
|
|
|
|
|
|
} else { |
132
|
0
|
|
|
|
|
|
return $str; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Maybe ... |
137
|
|
|
|
|
|
|
# |
138
|
|
|
|
|
|
|
# =item C<($atom, $bytes) = _to_TEXT ($X, $str)> |
139
|
|
|
|
|
|
|
# |
140
|
|
|
|
|
|
|
# Convert C<$str> to either C or C per L
|
141
|
|
|
|
|
|
|
# Properties> above. The returned C<$atom> (an integer) is the either |
142
|
|
|
|
|
|
|
# C or C and C<$bytes> are bytes of that type. |
143
|
|
|
|
|
|
|
# |
144
|
|
|
|
|
|
|
sub _to_TEXT { |
145
|
0
|
|
|
0
|
|
|
my ($X, $str) = @_; |
146
|
0
|
0
|
|
|
|
|
if (! is_utf8($str)) { |
147
|
|
|
|
|
|
|
# bytes or pre-5.8 taken to be latin-1 |
148
|
0
|
|
|
|
|
|
return (X11::AtomConstants::STRING(), $str); |
149
|
|
|
|
|
|
|
} |
150
|
0
|
|
|
|
|
|
require Encode; |
151
|
|
|
|
|
|
|
{ |
152
|
0
|
|
|
|
|
|
my $input = $str; # don't clobber $str |
|
0
|
|
|
|
|
|
|
153
|
0
|
|
|
|
|
|
my $bytes = Encode::encode ('iso-8859-1', $input, Encode::FB_QUIET()); |
154
|
0
|
0
|
|
|
|
|
if (length($input) == 0) { |
155
|
|
|
|
|
|
|
# latin-1 suffices |
156
|
0
|
|
|
|
|
|
return (X11::AtomConstants::STRING(), $bytes); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
0
|
|
|
|
|
|
require Encode::X11; |
160
|
0
|
|
|
|
|
|
return ($X->atom('COMPOUND_TEXT'), |
161
|
|
|
|
|
|
|
Encode::encode ('x11-compound-text', $str, Encode::FB_WARN())); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# Set a property on $window (integer XID) to a single CARD32 integer value. |
165
|
|
|
|
|
|
|
# $prop is the property (integer atom ID). |
166
|
|
|
|
|
|
|
# $type is the property type (integer atom ID). |
167
|
|
|
|
|
|
|
# $value is a 32-bit integer to store, or undef to delete the property. |
168
|
|
|
|
|
|
|
# |
169
|
|
|
|
|
|
|
# The ICCCM or similar specification will say what C<$type> should be in a |
170
|
|
|
|
|
|
|
# property. Often there's only one type, but in any case C<$type> indicates |
171
|
|
|
|
|
|
|
# what has been stored. This might be for example the atom for "PIXMAP" if |
172
|
|
|
|
|
|
|
# $value is a pixmap XID. Things which are counts or numbers are usually |
173
|
|
|
|
|
|
|
# the atom "CARDINAL". |
174
|
|
|
|
|
|
|
# |
175
|
|
|
|
|
|
|
sub _set_card32_property { |
176
|
0
|
|
|
0
|
|
|
my ($X, $window, $prop, $type, $value) = @_; |
177
|
0
|
0
|
|
|
|
|
if (defined $value) { |
178
|
0
|
|
|
|
|
|
$X->ChangeProperty ($window, |
179
|
|
|
|
|
|
|
$prop, # prop name |
180
|
|
|
|
|
|
|
$type, # type |
181
|
|
|
|
|
|
|
32, # format |
182
|
|
|
|
|
|
|
'Replace', |
183
|
|
|
|
|
|
|
pack ('L', $value)); |
184
|
|
|
|
|
|
|
} else { |
185
|
0
|
|
|
|
|
|
$X->DeleteProperty ($window, $prop); |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# or maybe $X->num('IDorNone',$xid) |
190
|
|
|
|
|
|
|
# $X->num('XID',$xid) |
191
|
|
|
|
|
|
|
sub _num_none { |
192
|
0
|
|
|
0
|
|
|
my ($xid) = @_; |
193
|
0
|
0
|
0
|
|
|
|
if (defined $xid && $xid eq "None") { |
194
|
0
|
|
|
|
|
|
return 0; |
195
|
|
|
|
|
|
|
} else { |
196
|
0
|
|
|
|
|
|
return $xid; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# or maybe $X->interp('IDorNone',$xid) or 'XIDorNone' |
201
|
|
|
|
|
|
|
sub _none_interp { |
202
|
0
|
|
|
0
|
|
|
my ($X, $xid) = @_; |
203
|
0
|
0
|
0
|
|
|
|
if ($X->{'do_interp'} && $xid == 0) { |
204
|
0
|
|
|
|
|
|
return 'None'; |
205
|
|
|
|
|
|
|
} else { |
206
|
0
|
|
|
|
|
|
return $xid; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# return $root or if that's undef then lookup root of $window |
211
|
|
|
|
|
|
|
sub _root_for_window { |
212
|
0
|
|
|
0
|
|
|
my ($X, $window, $root) = @_; |
213
|
0
|
0
|
|
|
|
|
if (! defined $root) { |
214
|
0
|
|
|
|
|
|
($root) = $X->QueryTree($window); |
215
|
|
|
|
|
|
|
} |
216
|
0
|
|
|
|
|
|
return $root; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
220
|
|
|
|
|
|
|
# frame_window_to_client() |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# /usr/share/doc/libxmu-headers/Xmu.txt.gz for XmuClientWindow() |
223
|
|
|
|
|
|
|
# https://bugs.freedesktop.org/show_bug.cgi?id=7474 |
224
|
|
|
|
|
|
|
# XmuClientWindow() bottom-up was hurting fluxbox and probably ion, pekwm |
225
|
|
|
|
|
|
|
# |
226
|
|
|
|
|
|
|
sub frame_window_to_client { |
227
|
0
|
|
|
0
|
1
|
|
my ($X, $frame) = @_; |
228
|
|
|
|
|
|
|
|
229
|
0
|
|
|
|
|
|
my @search = ($frame); |
230
|
0
|
|
|
|
|
|
my $property = $X->atom('WM_STATE'); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# ENHANCE-ME: do three reqs in parallel, better yet all reqs for an |
233
|
|
|
|
|
|
|
# @search depth level in parallel |
234
|
|
|
|
|
|
|
|
235
|
0
|
|
|
|
|
|
my $count = 0; |
236
|
0
|
|
|
|
|
|
OUTER: foreach (1 .. 5) { # limit search depth for safety |
237
|
0
|
|
|
|
|
|
my $child; |
238
|
0
|
|
|
|
|
|
foreach $child (splice @search) { # breadth-first search |
239
|
|
|
|
|
|
|
### look at: sprintf '0x%X', $child |
240
|
|
|
|
|
|
|
|
241
|
0
|
0
|
|
|
|
|
if ($count++ > 50) { |
242
|
|
|
|
|
|
|
### abandon search at count: $count |
243
|
0
|
|
|
|
|
|
return undef; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
{ |
247
|
0
|
|
|
|
|
|
my $ret = $X->robust_req ('GetWindowAttributes', $child); |
248
|
0
|
0
|
|
|
|
|
if (! ref $ret) { |
249
|
|
|
|
|
|
|
### some error, skip this child |
250
|
0
|
|
|
|
|
|
next; |
251
|
|
|
|
|
|
|
} |
252
|
0
|
|
|
|
|
|
my %attr = @$ret; |
253
|
|
|
|
|
|
|
### map_state: $attr{'map_state'} |
254
|
0
|
0
|
|
|
|
|
if ($attr{'map_state'} ne 'Viewable') { |
255
|
|
|
|
|
|
|
### not viewable, skip |
256
|
0
|
|
|
|
|
|
next; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
{ |
260
|
0
|
|
|
|
|
|
my $ret = $X->robust_req ('GetProperty', |
|
0
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
$child, $property, 'AnyPropertyType', |
262
|
|
|
|
|
|
|
0, # offset |
263
|
|
|
|
|
|
|
0, # length |
264
|
|
|
|
|
|
|
0); # delete; |
265
|
0
|
0
|
|
|
|
|
if (! ref $ret) { |
266
|
|
|
|
|
|
|
### some error, skip this child |
267
|
0
|
|
|
|
|
|
next; |
268
|
|
|
|
|
|
|
} |
269
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) = @$ret; |
270
|
0
|
0
|
|
|
|
|
if ($type) { |
271
|
|
|
|
|
|
|
### found |
272
|
0
|
|
|
|
|
|
return $child; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
{ |
276
|
0
|
|
|
|
|
|
my $ret = $X->robust_req ('QueryTree', $child); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
277
|
0
|
0
|
|
|
|
|
if (ref $ret) { |
278
|
0
|
|
|
|
|
|
my ($root, $parent, @children) = @$ret; |
279
|
|
|
|
|
|
|
### push children: @children |
280
|
|
|
|
|
|
|
# @children are in bottom up order, prefer the topmost |
281
|
0
|
|
|
|
|
|
push @search, reverse @children; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
### not found |
287
|
0
|
|
|
|
|
|
return undef; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
292
|
|
|
|
|
|
|
# root_to_virtual_root() |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# ENHANCE-ME: Could do all the GetProperty checks in parallel. |
295
|
|
|
|
|
|
|
# Could intern the VROOT atom during the QueryTree too. |
296
|
|
|
|
|
|
|
# |
297
|
|
|
|
|
|
|
sub root_to_virtual_root { |
298
|
0
|
|
|
0
|
1
|
|
my ($X, $root) = @_; |
299
|
|
|
|
|
|
|
### root_to_virtual_root(): $root |
300
|
|
|
|
|
|
|
|
301
|
0
|
|
|
|
|
|
my ($root_root, $root_parent, @toplevels) = $X->QueryTree($root); |
302
|
0
|
|
|
|
|
|
my $toplevel; |
303
|
0
|
|
|
|
|
|
foreach $toplevel (@toplevels) { |
304
|
|
|
|
|
|
|
### $toplevel |
305
|
0
|
|
|
|
|
|
my @ret = $X->robust_req ('GetProperty', |
306
|
|
|
|
|
|
|
$toplevel, |
307
|
|
|
|
|
|
|
$X->atom('__SWM_VROOT'), |
308
|
|
|
|
|
|
|
X11::AtomConstants::WINDOW(), # type |
309
|
|
|
|
|
|
|
0, # offset |
310
|
|
|
|
|
|
|
1, # length x 32bits |
311
|
|
|
|
|
|
|
0); # delete; |
312
|
|
|
|
|
|
|
### @ret |
313
|
0
|
0
|
|
|
|
|
next unless ref $ret[0]; # ignore errors from toplevels destroyed etc |
314
|
|
|
|
|
|
|
|
315
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) = @{$ret[0]}; |
|
0
|
|
|
|
|
|
|
316
|
0
|
0
|
|
|
|
|
if (my $vroot = unpack 'L', $value) { |
317
|
|
|
|
|
|
|
### found: $vroot |
318
|
0
|
|
|
|
|
|
return $vroot; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} |
321
|
0
|
|
|
|
|
|
return $root; |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
326
|
|
|
|
|
|
|
# WM_CLASS |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub set_wm_class { |
329
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $instance, $class) = @_; |
330
|
0
|
0
|
|
|
|
|
if (defined $instance) { |
331
|
0
|
|
|
|
|
|
my $str = _to_STRING($instance)."\0"._to_STRING($class)."\0"; |
332
|
0
|
|
|
|
|
|
$X->ChangeProperty($window, |
333
|
|
|
|
|
|
|
X11::AtomConstants::WM_CLASS(), # prop |
334
|
|
|
|
|
|
|
X11::AtomConstants::STRING(), # type |
335
|
|
|
|
|
|
|
8, # byte format |
336
|
|
|
|
|
|
|
'Replace', |
337
|
|
|
|
|
|
|
$str); |
338
|
|
|
|
|
|
|
} else { |
339
|
0
|
|
|
|
|
|
$X->DeleteProperty ($window, X11::AtomConstants::WM_CLASS()); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
345
|
|
|
|
|
|
|
# WM_CLIENT_MACHINE |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub set_wm_client_machine { |
348
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $hostname) = @_; |
349
|
0
|
|
|
|
|
|
set_text_property ($X, $window, |
350
|
|
|
|
|
|
|
X11::AtomConstants::WM_CLIENT_MACHINE(), $hostname); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
sub set_wm_client_machine_from_syshostname { |
354
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
355
|
0
|
|
|
|
|
|
require Sys::Hostname; |
356
|
0
|
|
|
|
|
|
set_wm_client_machine ($X, $window, eval { Sys::Hostname::hostname() }); |
|
0
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
361
|
|
|
|
|
|
|
# WM_COMMAND |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
sub set_wm_command { |
364
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
365
|
0
|
|
|
|
|
|
my $window = shift; |
366
|
|
|
|
|
|
|
|
367
|
0
|
0
|
0
|
|
|
|
if (@_ && ! defined $_[0]) { |
368
|
|
|
|
|
|
|
# this not documented ... |
369
|
0
|
|
|
|
|
|
$X->DeleteProperty ($window, X11::AtomConstants::WM_COMMAND()); |
370
|
0
|
|
|
|
|
|
return; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# cf join() gives a wide-char result if any parts wide, upgrading byte |
374
|
|
|
|
|
|
|
# strings as if they were latin-1 |
375
|
0
|
|
|
|
|
|
my $value = ''; |
376
|
0
|
|
|
|
|
|
my $type = X11::AtomConstants::STRING(); |
377
|
0
|
|
|
|
|
|
my $str; |
378
|
0
|
|
|
|
|
|
foreach $str (@_) { |
379
|
0
|
|
|
|
|
|
my ($atom, $bytes) = _to_TEXT($X,$str); |
380
|
0
|
0
|
|
|
|
|
if ($atom != X11::AtomConstants::STRING()) { |
381
|
0
|
|
|
|
|
|
$type = $atom; # COMPOUND_TEXT if any part needs COMPOUND_TEXT |
382
|
|
|
|
|
|
|
} |
383
|
0
|
|
|
|
|
|
$value .= "$bytes\0"; |
384
|
|
|
|
|
|
|
} |
385
|
0
|
0
|
|
|
|
|
if ($value eq "\0") { |
386
|
0
|
|
|
|
|
|
$value = ""; # this not documented ... |
387
|
|
|
|
|
|
|
# C<$command> can be an empty string "" to mean no known command as a |
388
|
|
|
|
|
|
|
# reply to C ... maybe |
389
|
|
|
|
|
|
|
} |
390
|
0
|
|
|
|
|
|
$X->ChangeProperty ($window, |
391
|
|
|
|
|
|
|
X11::AtomConstants::WM_COMMAND(), # prop name |
392
|
|
|
|
|
|
|
$type, # type |
393
|
|
|
|
|
|
|
8, # format |
394
|
|
|
|
|
|
|
'Replace', |
395
|
|
|
|
|
|
|
$value); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
400
|
|
|
|
|
|
|
# WM_ICON_SIZE |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub get_wm_icon_size { |
403
|
0
|
|
|
0
|
1
|
|
my ($X, $root) = @_; |
404
|
0
|
0
|
|
|
|
|
if (! defined $root) { |
405
|
0
|
|
|
|
|
|
$root = $X->root; |
406
|
|
|
|
|
|
|
} |
407
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) |
408
|
|
|
|
|
|
|
= $X->GetProperty ($root, |
409
|
|
|
|
|
|
|
X11::AtomConstants::WM_ICON_SIZE(), # property |
410
|
|
|
|
|
|
|
X11::AtomConstants::WM_ICON_SIZE(), # type |
411
|
|
|
|
|
|
|
0, # offset |
412
|
|
|
|
|
|
|
6, # length CARD32s |
413
|
|
|
|
|
|
|
0); # delete; |
414
|
0
|
0
|
|
|
|
|
if ($format == 32) { |
415
|
0
|
|
|
|
|
|
return unpack 'L6', $value; |
416
|
|
|
|
|
|
|
} else { |
417
|
0
|
|
|
|
|
|
return; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
423
|
|
|
|
|
|
|
# WM_HINTS |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub set_wm_hints { |
426
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
427
|
0
|
|
|
|
|
|
my $window = shift; |
428
|
|
|
|
|
|
|
### set_wm_hints(): @_ |
429
|
|
|
|
|
|
|
### set cards: map {sprintf '%#x',$_} unpack 'L*', pack_wm_hints($X,@_) |
430
|
0
|
|
|
|
|
|
$X->ChangeProperty($window, |
431
|
|
|
|
|
|
|
X11::AtomConstants::WM_HINTS(), # prop name |
432
|
|
|
|
|
|
|
X11::AtomConstants::WM_HINTS(), # type |
433
|
|
|
|
|
|
|
32, # format |
434
|
|
|
|
|
|
|
'Replace', |
435
|
|
|
|
|
|
|
pack_wm_hints($X, @_)); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub get_wm_hints { |
439
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
440
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) |
441
|
|
|
|
|
|
|
= $X->GetProperty ($window, |
442
|
|
|
|
|
|
|
X11::AtomConstants::WM_HINTS(), # prop name |
443
|
|
|
|
|
|
|
X11::AtomConstants::WM_HINTS(), # type |
444
|
|
|
|
|
|
|
0, # offset |
445
|
|
|
|
|
|
|
9, # length($format), of CARD32 |
446
|
|
|
|
|
|
|
0); # no delete |
447
|
0
|
0
|
|
|
|
|
if ($format == 32) { |
448
|
|
|
|
|
|
|
### got cards: map {sprintf '%#x',$_} unpack 'L*', $value |
449
|
0
|
|
|
|
|
|
return unpack_wm_hints ($X, $value); |
450
|
|
|
|
|
|
|
} else { |
451
|
0
|
|
|
|
|
|
return; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
sub change_wm_hints { |
456
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
457
|
0
|
|
|
|
|
|
my $window = shift; |
458
|
0
|
|
|
|
|
|
set_wm_hints ($X, $window, get_wm_hints($X,$window), @_); |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
{ |
462
|
|
|
|
|
|
|
my $format = 'LLLLLllLL'; |
463
|
|
|
|
|
|
|
# The C hint was called "visible" in X11R5. The name "urgency" |
464
|
|
|
|
|
|
|
# is used here per X11R6. The actual field sent and received is the same. |
465
|
|
|
|
|
|
|
# |
466
|
|
|
|
|
|
|
my %key_to_flag = (input => 1, |
467
|
|
|
|
|
|
|
initial_state => 2, |
468
|
|
|
|
|
|
|
icon_pixmap => 4, |
469
|
|
|
|
|
|
|
icon_window => 8, |
470
|
|
|
|
|
|
|
icon_x => 16, |
471
|
|
|
|
|
|
|
icon_y => 16, |
472
|
|
|
|
|
|
|
icon_mask => 32, |
473
|
|
|
|
|
|
|
window_group => 64, |
474
|
|
|
|
|
|
|
# message => 128, # in the code, obsolete |
475
|
|
|
|
|
|
|
# urgency => 256, # in the code |
476
|
|
|
|
|
|
|
); |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
sub pack_wm_hints { |
479
|
0
|
|
|
0
|
1
|
|
my ($X, %hint) = @_; |
480
|
|
|
|
|
|
|
### pack_wm_hints(): %hint |
481
|
0
|
|
|
|
|
|
my $flags = 0; |
482
|
0
|
0
|
|
|
|
|
if (delete $hint{'message'}) { |
483
|
0
|
|
|
|
|
|
$flags = 128; |
484
|
|
|
|
|
|
|
} |
485
|
0
|
0
|
|
|
|
|
if (delete $hint{'urgency'}) { |
486
|
0
|
|
|
|
|
|
$flags |= 256; |
487
|
|
|
|
|
|
|
} |
488
|
0
|
|
|
|
|
|
my $key; |
489
|
0
|
|
|
|
|
|
foreach $key (keys %hint) { |
490
|
0
|
|
0
|
|
|
|
my $flag_bit = $key_to_flag{$key} |
491
|
|
|
|
|
|
|
|| croak "Unknown WM_HINT field: ",$key; |
492
|
0
|
0
|
|
|
|
|
if (defined $hint{$key}) { |
493
|
0
|
|
|
|
|
|
$flags |= $flag_bit; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
return pack ($format, |
497
|
|
|
|
|
|
|
$flags, |
498
|
|
|
|
|
|
|
$hint{'input'} || 0, # CARD32 bool |
499
|
|
|
|
|
|
|
_wmstate_num($hint{'initial_state'}) || 0, # CARD32 enum |
500
|
|
|
|
|
|
|
_num_none($hint{'icon_pixmap'}) || 0, # PIXMAP |
501
|
|
|
|
|
|
|
_num_none($hint{'icon_window'}) || 0, # WINDOW |
502
|
|
|
|
|
|
|
$hint{'icon_x'} || 0, # INT32 |
503
|
|
|
|
|
|
|
$hint{'icon_y'} || 0, # INT32 |
504
|
|
|
|
|
|
|
_num_none($hint{'icon_mask'}) || 0, # PIXMAP |
505
|
0
|
|
0
|
|
|
|
_num_none($hint{'window_group'}) || 0); # WINDOW |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# X11R2 Xlib had a bug where XSetWMHints() set a WM_HINTS property to only |
509
|
|
|
|
|
|
|
# 8 CARD32s, chopping off the window_group field. This was due to |
510
|
|
|
|
|
|
|
# Xatomtype.h NumPropWMHintsElements being 8 instead of 9. If the length |
511
|
|
|
|
|
|
|
# of $bytes here is only 8 then ignore any window_group bit in the flags |
512
|
|
|
|
|
|
|
# and don't return a window_group field. X11R2 source available at |
513
|
|
|
|
|
|
|
# http://ftp.x.org/pub/X11R2/X.V11R2.tar.gz |
514
|
|
|
|
|
|
|
# |
515
|
|
|
|
|
|
|
my @keys = ('input', |
516
|
|
|
|
|
|
|
'initial_state', |
517
|
|
|
|
|
|
|
'icon_pixmap', |
518
|
|
|
|
|
|
|
'icon_window', |
519
|
|
|
|
|
|
|
'icon_x', |
520
|
|
|
|
|
|
|
'icon_y', |
521
|
|
|
|
|
|
|
'icon_mask', |
522
|
|
|
|
|
|
|
'window_group', |
523
|
|
|
|
|
|
|
# 'message', # in the code, and obsolete ... |
524
|
|
|
|
|
|
|
# 'urgency', # in the code |
525
|
|
|
|
|
|
|
); |
526
|
|
|
|
|
|
|
my @interp = (\&_unchanged, # input |
527
|
|
|
|
|
|
|
\&_wmstate_interp, # initial_state |
528
|
|
|
|
|
|
|
\&_none_interp, # icon_pixmap |
529
|
|
|
|
|
|
|
\&_none_interp, # icon_window |
530
|
|
|
|
|
|
|
\&_unchanged, # icon_x |
531
|
|
|
|
|
|
|
\&_unchanged, # icon_y |
532
|
|
|
|
|
|
|
\&_none_interp, # icon_mask |
533
|
|
|
|
|
|
|
\&_none_interp, # window_group |
534
|
|
|
|
|
|
|
); |
535
|
|
|
|
|
|
|
sub unpack_wm_hints { |
536
|
0
|
|
|
0
|
1
|
|
my ($X, $bytes) = @_; |
537
|
|
|
|
|
|
|
### unpack_wm_hints(): unpack 'L*', $bytes |
538
|
0
|
|
|
|
|
|
my ($flags, @values) = unpack ($format, $bytes); |
539
|
0
|
|
|
|
|
|
my $bit = 1; |
540
|
0
|
|
|
|
|
|
my @ret; |
541
|
|
|
|
|
|
|
my $i; |
542
|
0
|
|
|
|
|
|
foreach $i (0 .. $#keys) { |
543
|
0
|
|
|
|
|
|
my $value = $values[$i]; |
544
|
0
|
0
|
|
|
|
|
if (! defined $value) { |
545
|
|
|
|
|
|
|
# if $bytes is only 8 CARD32s as from X11R2 then omit window_group |
546
|
|
|
|
|
|
|
# from the return |
547
|
0
|
|
|
|
|
|
next; |
548
|
|
|
|
|
|
|
} |
549
|
0
|
0
|
|
|
|
|
if ($flags & $bit) { |
550
|
0
|
|
|
|
|
|
push @ret, $keys[$i], &{$interp[$i]}($X, $value); |
|
0
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
} |
552
|
0
|
|
|
|
|
|
$bit <<= ($i!=4); # icon_x,icon_y both at $bit==16 |
553
|
|
|
|
|
|
|
} |
554
|
0
|
0
|
|
|
|
|
if ($flags & 128) { |
555
|
0
|
|
|
|
|
|
push @ret, message => 1; |
556
|
|
|
|
|
|
|
} |
557
|
0
|
0
|
|
|
|
|
if ($flags & 256) { |
558
|
0
|
|
|
|
|
|
push @ret, urgency => 1; |
559
|
|
|
|
|
|
|
} |
560
|
0
|
|
|
|
|
|
return @ret; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
sub _unchanged { |
565
|
0
|
|
|
0
|
|
|
my ($X, $value) = @_; |
566
|
0
|
|
|
|
|
|
return $value; |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
571
|
|
|
|
|
|
|
# WM_ICON_NAME |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
sub set_wm_icon_name { |
574
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $name) = @_; |
575
|
0
|
|
|
|
|
|
set_text_property ($X, $window, X11::AtomConstants::WM_ICON_NAME(), $name); |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
580
|
|
|
|
|
|
|
# WM_NAME |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
sub set_wm_name { |
583
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $name) = @_; |
584
|
0
|
|
|
|
|
|
set_text_property ($X, $window, X11::AtomConstants::WM_NAME(), $name); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
588
|
|
|
|
|
|
|
# WM_PROTOCOLS |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
sub set_wm_protocols { |
591
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
592
|
0
|
|
|
|
|
|
my $window = shift; |
593
|
0
|
|
|
|
|
|
my $property = $X->atom('WM_PROTOCOLS'); |
594
|
0
|
0
|
|
|
|
|
if (@_) { |
595
|
0
|
|
|
|
|
|
X11::Protocol::Other::set_property_atoms ($X, $window, $property, |
596
|
|
|
|
|
|
|
_to_atom_nums($X,@_)); |
597
|
|
|
|
|
|
|
} else { |
598
|
0
|
|
|
|
|
|
$X->DeleteProperty ($window, $property); |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
# Take atom names or numbers, return atom numbers. Convenient, but atom |
603
|
|
|
|
|
|
|
# names can be numbers so this is good only where don't have such names. |
604
|
|
|
|
|
|
|
sub _to_atom_nums { |
605
|
0
|
|
|
0
|
|
|
my $X = shift; |
606
|
0
|
0
|
|
|
|
|
return map { ($_ =~ /^\d+$/ ? $_ : $X->atom($_)) } @_; |
|
0
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
611
|
|
|
|
|
|
|
# WM_STATE enum |
612
|
|
|
|
|
|
|
# For internal use yet ... |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
{ |
615
|
|
|
|
|
|
|
my %wmstate = (WithdrawnState => 0, |
616
|
|
|
|
|
|
|
DontCareState => 0, # no longer in ICCCM |
617
|
|
|
|
|
|
|
NormalState => 1, |
618
|
|
|
|
|
|
|
ZoomState => 2, # no longer in ICCCM |
619
|
|
|
|
|
|
|
IconicState => 3, |
620
|
|
|
|
|
|
|
InactiveState => 4, # no longer in ICCCM |
621
|
|
|
|
|
|
|
); |
622
|
|
|
|
|
|
|
sub _wmstate_num { |
623
|
0
|
|
|
0
|
|
|
my ($wmstate) = @_; |
624
|
0
|
0
|
0
|
|
|
|
if (defined $wmstate && defined (my $num = $wmstate{$wmstate})) { |
625
|
0
|
|
|
|
|
|
return $num; |
626
|
|
|
|
|
|
|
} |
627
|
0
|
|
|
|
|
|
return $wmstate; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
{ |
632
|
|
|
|
|
|
|
# DontCareState==0 no longer ICCCM |
633
|
|
|
|
|
|
|
my @wmstate = ('WithdrawnState', # 0 |
634
|
|
|
|
|
|
|
'NormalState', # 1 |
635
|
|
|
|
|
|
|
'ZoomState', # 2, no longer ICCCM |
636
|
|
|
|
|
|
|
'IconicState', # 3 |
637
|
|
|
|
|
|
|
'InactiveState', # 4, no longer in ICCCM |
638
|
|
|
|
|
|
|
); |
639
|
|
|
|
|
|
|
sub _wmstate_interp { |
640
|
0
|
|
|
0
|
|
|
my ($X, $num) = @_; |
641
|
0
|
0
|
0
|
|
|
|
if ($X->{'do_interp'} && defined (my $str = $wmstate[$num])) { |
642
|
0
|
|
|
|
|
|
return $str; |
643
|
|
|
|
|
|
|
} |
644
|
0
|
|
|
|
|
|
return $num; |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
# Maybe through $X->interp() with ... |
649
|
|
|
|
|
|
|
# |
650
|
|
|
|
|
|
|
# { |
651
|
|
|
|
|
|
|
# # $X->interp('WmState',$num); |
652
|
|
|
|
|
|
|
# # $X->num('WmState',$str); |
653
|
|
|
|
|
|
|
# my %const_arrays |
654
|
|
|
|
|
|
|
# = ( |
655
|
|
|
|
|
|
|
# WmState => ['WithdrawnState', # 0 |
656
|
|
|
|
|
|
|
# 'NormalState', # 1 |
657
|
|
|
|
|
|
|
# 'ZoomState', # 2, no longer ICCCM |
658
|
|
|
|
|
|
|
# 'IconicState', # 3 |
659
|
|
|
|
|
|
|
# 'InactiveState', # 4, no longer in ICCCM |
660
|
|
|
|
|
|
|
# ], |
661
|
|
|
|
|
|
|
# ); |
662
|
|
|
|
|
|
|
# |
663
|
|
|
|
|
|
|
# my %const_hashes |
664
|
|
|
|
|
|
|
# = (map { $_ => { X11::Protocol::make_num_hash($const_arrays{$_}) } } |
665
|
|
|
|
|
|
|
# keys %const_arrays); |
666
|
|
|
|
|
|
|
# |
667
|
|
|
|
|
|
|
# |
668
|
|
|
|
|
|
|
# sub ext_const_init { |
669
|
|
|
|
|
|
|
# my ($X) = @_; |
670
|
|
|
|
|
|
|
# unless ($X->{'ext_const'}->{'WmState'}) { |
671
|
|
|
|
|
|
|
# %{$X->{'ext_const'}} = (%{$X->{'ext_const'}}, %const_arrays); |
672
|
|
|
|
|
|
|
# $X->{'ext_const_num'} ||= {}; |
673
|
|
|
|
|
|
|
# %{$X->{'ext_const_num'}} = (%{$X->{'ext_const_num'}}, %const_hashes); |
674
|
|
|
|
|
|
|
# } |
675
|
|
|
|
|
|
|
# } |
676
|
|
|
|
|
|
|
# } |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
680
|
|
|
|
|
|
|
# WM_STATE |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
sub get_wm_state { |
683
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
684
|
0
|
|
|
|
|
|
my $xa_wm_state = $X->atom('WM_STATE'); |
685
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) |
686
|
|
|
|
|
|
|
= $X->GetProperty ($window, |
687
|
|
|
|
|
|
|
$xa_wm_state, # property |
688
|
|
|
|
|
|
|
$xa_wm_state, # type |
689
|
|
|
|
|
|
|
0, # offset |
690
|
|
|
|
|
|
|
2, # length, 2 x CARD32 |
691
|
|
|
|
|
|
|
0); # delete |
692
|
0
|
0
|
|
|
|
|
if ($format == 32) { |
693
|
0
|
|
|
|
|
|
return unpack_wm_state($X,$value); |
694
|
|
|
|
|
|
|
} else { |
695
|
0
|
|
|
|
|
|
return; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
sub unpack_wm_state { |
700
|
0
|
|
|
0
|
1
|
|
my ($X, $data) = @_; |
701
|
0
|
|
|
|
|
|
my ($state, $icon_window) = unpack 'LL', $data; |
702
|
0
|
|
|
|
|
|
return (_wmstate_interp($X,$state), _none_interp($X,$icon_window)); |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
707
|
|
|
|
|
|
|
# WM_STATE transitions |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
# cf /so/xorg/libX11-1.4.0/src/Iconify.c |
710
|
|
|
|
|
|
|
# |
711
|
|
|
|
|
|
|
sub iconify { |
712
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $root) = @_; |
713
|
|
|
|
|
|
|
### iconify(): $window |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# The icccm spec doesn't seem to say any particular event mask for this |
716
|
|
|
|
|
|
|
# ClientMessage, but follow Xlib Iconify.c and send |
717
|
|
|
|
|
|
|
# SubstructureRedirect+SubstructureNotify. |
718
|
|
|
|
|
|
|
# |
719
|
0
|
|
|
|
|
|
_send_event_to_wm ($X, _root_for_window($X,$window,$root), |
720
|
|
|
|
|
|
|
name => 'ClientMessage', |
721
|
|
|
|
|
|
|
window => $window, |
722
|
|
|
|
|
|
|
type => $X->atom('WM_CHANGE_STATE'), |
723
|
|
|
|
|
|
|
format => 32, |
724
|
|
|
|
|
|
|
data => pack('L5', 3)); # 3=IconicState |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
# cf /so/xorg/libX11-1.4.0/src/Withdraw.c |
728
|
|
|
|
|
|
|
# |
729
|
|
|
|
|
|
|
sub withdraw { |
730
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $root) = @_; |
731
|
|
|
|
|
|
|
### withdraw(): $window, $root |
732
|
0
|
|
|
|
|
|
$root = _root_for_window($X,$window,$root); # QueryTree before unmap |
733
|
0
|
|
|
|
|
|
$X->UnmapWindow ($window); |
734
|
0
|
|
|
|
|
|
_send_event_to_wm ($X, $root, |
735
|
|
|
|
|
|
|
name => 'UnmapNotify', |
736
|
|
|
|
|
|
|
event => $root, |
737
|
|
|
|
|
|
|
window => $window, |
738
|
|
|
|
|
|
|
from_configure => 0); |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
# =item C<_send_event_to_wm ($X, $root, name=E$str,...)> |
742
|
|
|
|
|
|
|
# |
743
|
|
|
|
|
|
|
# Send an event to the window manager by C<$X-ESendEvent()> to the given |
744
|
|
|
|
|
|
|
# C<$root> (integer XID of a root window). |
745
|
|
|
|
|
|
|
# |
746
|
|
|
|
|
|
|
# The key/value parameters specify an event packet as per |
747
|
|
|
|
|
|
|
# C<$X-Epack_event()>. Often this is a C event, but any |
748
|
|
|
|
|
|
|
# type can be sent. (For example C sends a synthetic |
749
|
|
|
|
|
|
|
# C.) |
750
|
|
|
|
|
|
|
# |
751
|
|
|
|
|
|
|
# But: event-mask=ColormapChange for own colormap install setups ... |
752
|
|
|
|
|
|
|
# But: event-mask=StructureNotify for "manager" acquiring resource ... |
753
|
|
|
|
|
|
|
# |
754
|
|
|
|
|
|
|
sub _send_event_to_wm { |
755
|
0
|
|
|
0
|
|
|
my $X = shift; |
756
|
0
|
|
|
|
|
|
my $root = shift; |
757
|
0
|
|
|
|
|
|
$X->SendEvent ($root, |
758
|
|
|
|
|
|
|
0, # all clients |
759
|
|
|
|
|
|
|
$X->pack_event_mask('SubstructureRedirect', |
760
|
|
|
|
|
|
|
'SubstructureNotify'), |
761
|
|
|
|
|
|
|
$X->pack_event(@_)); |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
766
|
|
|
|
|
|
|
# WM_TRANSIENT |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# $transient_for eq 'None' supported for generality, but not yet documented |
769
|
|
|
|
|
|
|
# since not sure such a property value would be ICCCM compliant |
770
|
|
|
|
|
|
|
# |
771
|
|
|
|
|
|
|
sub set_wm_transient_for { |
772
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $transient_for) = @_; |
773
|
0
|
|
|
|
|
|
_set_card32_property ($X, $window, |
774
|
|
|
|
|
|
|
X11::AtomConstants::WM_TRANSIENT_FOR(), # prop name |
775
|
|
|
|
|
|
|
X11::AtomConstants::WINDOW(), # type |
776
|
|
|
|
|
|
|
_num_none ($transient_for)); |
777
|
|
|
|
|
|
|
} |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# not sure about this, might be only used by window manager, not a client |
780
|
|
|
|
|
|
|
# =item C<$transient_for = X11::Protocol::WM::get_wm_transient_for ($X, $window)> |
781
|
|
|
|
|
|
|
# sub get_wm_transient_for { |
782
|
|
|
|
|
|
|
# my ($X, $window) = @_; |
783
|
|
|
|
|
|
|
# _get_property_card32 ($X, $window, |
784
|
|
|
|
|
|
|
# X11::AtomConstants::WM_TRANSIENT_FOR(), |
785
|
|
|
|
|
|
|
# X11::AtomConstants::WINDOW()); |
786
|
|
|
|
|
|
|
# } |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
790
|
|
|
|
|
|
|
# _MOTIF_WM_HINTS |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
sub set_motif_wm_hints { |
793
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
794
|
0
|
|
|
|
|
|
my $window = shift; |
795
|
0
|
|
|
|
|
|
$X->ChangeProperty($window, |
796
|
|
|
|
|
|
|
$X->atom('_MOTIF_WM_HINTS'), # property |
797
|
|
|
|
|
|
|
$X->atom('_MOTIF_WM_HINTS'), # type |
798
|
|
|
|
|
|
|
32, # format |
799
|
|
|
|
|
|
|
'Replace', |
800
|
|
|
|
|
|
|
pack_motif_wm_hints ($X, @_)); |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
{ |
804
|
|
|
|
|
|
|
# per /usr/include/Xm/MwmUtil.h |
805
|
|
|
|
|
|
|
my %key_to_flag = (functions => 1, |
806
|
|
|
|
|
|
|
decorations => 2, |
807
|
|
|
|
|
|
|
input_mode => 4, |
808
|
|
|
|
|
|
|
status => 8, |
809
|
|
|
|
|
|
|
); |
810
|
|
|
|
|
|
|
sub pack_motif_wm_hints { |
811
|
0
|
|
|
0
|
0
|
|
my ($X, %hint) = @_; |
812
|
|
|
|
|
|
|
|
813
|
0
|
|
|
|
|
|
my $flags = 0; |
814
|
0
|
|
|
|
|
|
my $key; |
815
|
0
|
|
|
|
|
|
foreach $key (keys %hint) { |
816
|
0
|
0
|
|
|
|
|
if (defined $hint{$key}) { |
817
|
0
|
|
|
|
|
|
$flags |= $key_to_flag{$key}; |
818
|
|
|
|
|
|
|
} else { |
819
|
0
|
|
|
|
|
|
croak "Unrecognised _MOTIF_WM_HINTS field: ",$key; |
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
pack ('L5', |
823
|
|
|
|
|
|
|
$flags, |
824
|
|
|
|
|
|
|
$hint{'functions'} || 0, |
825
|
|
|
|
|
|
|
$hint{'decorations'} || 0, |
826
|
|
|
|
|
|
|
_motif_input_mode_num($X, $hint{'input_mode'} || 0), |
827
|
0
|
|
0
|
|
|
|
$hint{'status'} || 0); |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
{ |
831
|
|
|
|
|
|
|
my %input_mode_num = (modeless => 0, |
832
|
|
|
|
|
|
|
primary_application_modal => 1, |
833
|
|
|
|
|
|
|
system_modal => 2, |
834
|
|
|
|
|
|
|
full_application_modal => 3, |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
# application_modal => 1, |
837
|
|
|
|
|
|
|
); |
838
|
|
|
|
|
|
|
sub _motif_input_mode_num { |
839
|
0
|
|
|
0
|
|
|
my ($X, $input_mode) = @_; |
840
|
0
|
0
|
|
|
|
|
if (exists $input_mode_num{$input_mode}) { |
841
|
0
|
|
|
|
|
|
return $input_mode_num{$input_mode}; |
842
|
|
|
|
|
|
|
} else { |
843
|
0
|
|
|
|
|
|
return $input_mode; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
851
|
|
|
|
|
|
|
# _NET_FRAME_EXTENTS |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub get_net_frame_extents { |
854
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
855
|
0
|
|
|
|
|
|
my ($value, $type, $format, $bytes_after) |
856
|
|
|
|
|
|
|
= $X->GetProperty ($window, |
857
|
|
|
|
|
|
|
$X->atom('_NET_FRAME_EXTENTS'), # property |
858
|
|
|
|
|
|
|
X11::AtomConstants::CARDINAL(), # type |
859
|
|
|
|
|
|
|
0, # offset |
860
|
|
|
|
|
|
|
4, # length, 4 x CARD32 |
861
|
|
|
|
|
|
|
0); # delete |
862
|
0
|
0
|
|
|
|
|
if ($format == 32) { |
863
|
0
|
|
|
|
|
|
return unpack 'L4', $value; |
864
|
|
|
|
|
|
|
} else { |
865
|
0
|
|
|
|
|
|
return; |
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
870
|
|
|
|
|
|
|
# _NET_WM_PID |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
sub set_net_wm_pid { |
873
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $pid) = @_; |
874
|
0
|
0
|
|
|
|
|
if (@_ < 3) { $pid = $$; } |
|
0
|
|
|
|
|
|
|
875
|
0
|
|
|
|
|
|
_set_card32_property ($X, |
876
|
|
|
|
|
|
|
$window, |
877
|
|
|
|
|
|
|
$X->atom('_NET_WM_PID'), |
878
|
|
|
|
|
|
|
X11::AtomConstants::CARDINAL(), |
879
|
|
|
|
|
|
|
$pid); |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
883
|
|
|
|
|
|
|
# _NET_WM_STATE |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
sub get_net_wm_state { |
886
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
887
|
|
|
|
|
|
|
# ENHANCE-ME: maybe atom_names() for parallel name fetch |
888
|
0
|
|
|
|
|
|
return map {_net_wm_state_interp($X,$_)} get_net_wm_state_atoms($X,$window); |
|
0
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
# $atom is an atom integer, return a string like "FULLSCREEN". |
891
|
|
|
|
|
|
|
sub _net_wm_state_interp { |
892
|
0
|
|
|
0
|
|
|
my ($X, $atom) = @_; |
893
|
0
|
|
|
|
|
|
my $state = $X->atom_name($atom); |
894
|
0
|
|
|
|
|
|
$state =~ s/^_NET_WM_STATE_//; |
895
|
0
|
|
|
|
|
|
return $state; |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
sub get_net_wm_state_atoms { |
899
|
0
|
|
|
0
|
1
|
|
my ($X, $window) = @_; |
900
|
0
|
|
|
|
|
|
return X11::Protocol::Other::get_property_atoms |
901
|
|
|
|
|
|
|
($X, $window, $X->atom('_NET_WM_STATE')); |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
# $state can be string like "FULLSCREEN" |
905
|
|
|
|
|
|
|
# string like "_NET_WM_STATE_FULLSCREEN" |
906
|
|
|
|
|
|
|
# integer atom number |
907
|
|
|
|
|
|
|
# Integer returned unchanged. |
908
|
|
|
|
|
|
|
# Otherwise get atom number of full name like "_NET_WM_STATE_FULLSCREEN". |
909
|
|
|
|
|
|
|
sub _net_wm_state_num { |
910
|
0
|
|
|
0
|
|
|
my ($X, $state) = @_; |
911
|
0
|
0
|
|
|
|
|
if (! defined $state) { |
912
|
0
|
|
|
|
|
|
return 0; |
913
|
|
|
|
|
|
|
} |
914
|
0
|
0
|
|
|
|
|
if ($state =~ /^\d+$/) { |
915
|
0
|
|
|
|
|
|
return $state; # a number already |
916
|
|
|
|
|
|
|
} |
917
|
0
|
0
|
|
|
|
|
if ($state !~ /^_NET_WM_STATE_/) { |
918
|
0
|
|
|
|
|
|
$state = '_NET_WM_STATE_' . $state; |
919
|
|
|
|
|
|
|
} |
920
|
0
|
|
|
|
|
|
return $X->atom($state); |
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
sub set_net_wm_state { |
924
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
925
|
0
|
|
|
|
|
|
my $window = shift; |
926
|
|
|
|
|
|
|
X11::Protocol::Other::set_property_atoms |
927
|
|
|
|
|
|
|
($X, $window, |
928
|
|
|
|
|
|
|
$X->atom('_NET_WM_STATE'), # property |
929
|
0
|
|
|
|
|
|
map {_net_wm_state_num($X,$_)} @_); # states |
|
0
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
{ |
933
|
|
|
|
|
|
|
my %_net_wm_state_action_num = (remove => 0, |
934
|
|
|
|
|
|
|
add => 1, |
935
|
|
|
|
|
|
|
toggle => 2); |
936
|
|
|
|
|
|
|
# $action is a string "add" etc, or a number 0,1,2. |
937
|
|
|
|
|
|
|
# Return a number 0,1,2. |
938
|
|
|
|
|
|
|
sub _net_wm_state_action_num { |
939
|
0
|
|
|
0
|
|
|
my ($X, $action) = @_; |
940
|
|
|
|
|
|
|
### _net_wm_state_action_num(): $action |
941
|
0
|
0
|
|
|
|
|
if ($action =~ /^\d+$/) { |
942
|
0
|
|
|
|
|
|
return $action; # a number already |
943
|
|
|
|
|
|
|
} |
944
|
0
|
|
|
|
|
|
my $num = $_net_wm_state_action_num{$action}; |
945
|
0
|
0
|
|
|
|
|
if (defined $num) { |
946
|
0
|
|
|
|
|
|
return $num; |
947
|
|
|
|
|
|
|
} |
948
|
0
|
|
|
|
|
|
croak 'Unrecognized _NET_WM_STATE action: ',$action; |
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
{ |
953
|
|
|
|
|
|
|
my %_net_wm_source_num = (none => 0, |
954
|
|
|
|
|
|
|
normal => 1, |
955
|
|
|
|
|
|
|
user => 2); |
956
|
|
|
|
|
|
|
# $source is a string "normal" etc, or a number 0,1,2. |
957
|
|
|
|
|
|
|
# Return a number 0,1,2. |
958
|
|
|
|
|
|
|
sub _net_wm_source_num { |
959
|
0
|
|
|
0
|
|
|
my ($X, $source) = @_; |
960
|
0
|
0
|
|
|
|
|
if (! defined $source) { |
961
|
0
|
|
|
|
|
|
return 1; # default "normal" |
962
|
|
|
|
|
|
|
} |
963
|
0
|
0
|
|
|
|
|
if ($source =~ /^\d+$/) { |
964
|
0
|
|
|
|
|
|
return $source; # a number already |
965
|
|
|
|
|
|
|
} |
966
|
0
|
|
|
|
|
|
my $num = $_net_wm_source_num{$source}; |
967
|
0
|
0
|
|
|
|
|
if (defined $num) { |
968
|
0
|
|
|
|
|
|
return $num; |
969
|
|
|
|
|
|
|
} |
970
|
0
|
|
|
|
|
|
croak 'Unrecognized _NET_WM source: ',$source; |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
sub change_net_wm_state { |
975
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $action, $state, %h) = @_; |
976
|
|
|
|
|
|
|
### change_net_wm_state() ... |
977
|
|
|
|
|
|
|
### $state |
978
|
|
|
|
|
|
|
### %h |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
my $root = X11::Protocol::WM::_root_for_window($X,$window, |
981
|
0
|
|
|
|
|
|
delete $h{'root'}); |
982
|
0
|
|
|
|
|
|
my $state2 = _net_wm_state_num($X, delete $h{'state2'}); |
983
|
0
|
|
|
|
|
|
my $source = _net_wm_source_num($X, delete $h{'source'}); |
984
|
0
|
0
|
|
|
|
|
if (%h) { |
985
|
0
|
|
|
|
|
|
croak "change_net_wm_state() unrecognised parameter(s): ", |
986
|
|
|
|
|
|
|
join(',',keys %h); |
987
|
|
|
|
|
|
|
} |
988
|
0
|
|
|
|
|
|
X11::Protocol::WM::_send_event_to_wm ($X, $root, |
989
|
|
|
|
|
|
|
name => 'ClientMessage', |
990
|
|
|
|
|
|
|
window => $window, |
991
|
|
|
|
|
|
|
type => $X->atom('_NET_WM_STATE'), |
992
|
|
|
|
|
|
|
format => 32, |
993
|
|
|
|
|
|
|
data => pack('L5', |
994
|
|
|
|
|
|
|
_net_wm_state_action_num($X, $action), |
995
|
|
|
|
|
|
|
_net_wm_state_num($X, $state), |
996
|
|
|
|
|
|
|
$state2, |
997
|
|
|
|
|
|
|
$source)); |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1001
|
|
|
|
|
|
|
# _NET_WM_WINDOW_TYPE |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
sub set_net_wm_window_type { |
1004
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $window_type) = @_; |
1005
|
0
|
|
|
|
|
|
X11::Protocol::Other::set_property_atoms |
1006
|
|
|
|
|
|
|
($X, $window, $X->atom('_NET_WM_WINDOW_TYPE'), |
1007
|
|
|
|
|
|
|
_net_wm_window_type_to_atom($X, $window_type)); |
1008
|
|
|
|
|
|
|
} |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
# not documented yet ... |
1011
|
|
|
|
|
|
|
sub _net_wm_window_type_to_atom { |
1012
|
0
|
|
|
0
|
|
|
my ($X, $window_type) = @_; |
1013
|
0
|
0
|
0
|
|
|
|
if (! defined $window_type || $window_type =~ /^\d+$/) { |
1014
|
0
|
|
|
|
|
|
return $window_type; |
1015
|
|
|
|
|
|
|
} else { |
1016
|
0
|
|
|
|
|
|
return $X->atom ("_NET_WM_WINDOW_TYPE_$window_type"); |
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
} |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# unless ($window_type =~ /^_NET_WM/) { |
1021
|
|
|
|
|
|
|
# } |
1022
|
|
|
|
|
|
|
# my ($akey, $atype) = _atoms ($X, |
1023
|
|
|
|
|
|
|
# '_NET_WM_WINDOW_TYPE', |
1024
|
|
|
|
|
|
|
# "_NET_WM_WINDOW_TYPE_$window_type"); |
1025
|
|
|
|
|
|
|
# a type stringcan be an atom integer, a full atom name like |
1026
|
|
|
|
|
|
|
# "_NET_WM_WINDOW_TYPE_NORMAL", or just the type part "NORMAL". |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1030
|
|
|
|
|
|
|
# _NET_WM_USER_TIME |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
sub set_net_wm_user_time { |
1033
|
0
|
|
|
0
|
1
|
|
my ($X, $window, $time) = @_; |
1034
|
0
|
|
|
|
|
|
_set_card32_property ($X, |
1035
|
|
|
|
|
|
|
$window, |
1036
|
|
|
|
|
|
|
$X->atom('_NET_WM_USER_TIME'), |
1037
|
|
|
|
|
|
|
X11::AtomConstants::CARDINAL(), |
1038
|
|
|
|
|
|
|
$time); |
1039
|
|
|
|
|
|
|
} |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1042
|
|
|
|
|
|
|
# WM_NORMAL_HINTS |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
sub set_wm_normal_hints { |
1045
|
0
|
|
|
0
|
1
|
|
my $X = shift; |
1046
|
0
|
|
|
|
|
|
my $window = shift; |
1047
|
0
|
|
|
|
|
|
$X->ChangeProperty($window, |
1048
|
|
|
|
|
|
|
X11::AtomConstants::WM_NORMAL_HINTS(), # property |
1049
|
|
|
|
|
|
|
X11::AtomConstants::WM_SIZE_HINTS(), # type |
1050
|
|
|
|
|
|
|
32, # format |
1051
|
|
|
|
|
|
|
'Replace', |
1052
|
|
|
|
|
|
|
pack_wm_size_hints ($X, @_)); |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
{ |
1056
|
|
|
|
|
|
|
my %key_to_flag = |
1057
|
|
|
|
|
|
|
(user_position => 1, # user-specified window x,y |
1058
|
|
|
|
|
|
|
user_size => 2, # user-specified win width,height |
1059
|
|
|
|
|
|
|
program_position => 4, # program-specified window x,y |
1060
|
|
|
|
|
|
|
program_size => 8, # program-specified win width,height |
1061
|
|
|
|
|
|
|
min_width => 16, |
1062
|
|
|
|
|
|
|
min_height => 16, |
1063
|
|
|
|
|
|
|
max_width => 32, |
1064
|
|
|
|
|
|
|
max_height => 32, |
1065
|
|
|
|
|
|
|
width_inc => 64, |
1066
|
|
|
|
|
|
|
height_inc => 64, |
1067
|
|
|
|
|
|
|
min_aspect => 128, |
1068
|
|
|
|
|
|
|
min_aspect_num => 128, |
1069
|
|
|
|
|
|
|
min_aspect_den => 128, |
1070
|
|
|
|
|
|
|
max_aspect => 128, |
1071
|
|
|
|
|
|
|
max_aspect_num => 128, |
1072
|
|
|
|
|
|
|
max_aspect_den => 128, |
1073
|
|
|
|
|
|
|
base_width => 256, |
1074
|
|
|
|
|
|
|
base_height => 256, |
1075
|
|
|
|
|
|
|
win_gravity => 512, |
1076
|
|
|
|
|
|
|
); |
1077
|
|
|
|
|
|
|
sub pack_wm_size_hints { |
1078
|
0
|
|
|
0
|
0
|
|
my ($X, %hint) = @_; |
1079
|
|
|
|
|
|
|
### pack_wm_size_hints(): %hint |
1080
|
|
|
|
|
|
|
|
1081
|
0
|
|
|
|
|
|
my $flags = 0; |
1082
|
0
|
|
|
|
|
|
my $key; |
1083
|
0
|
|
|
|
|
|
foreach $key (keys %hint) { |
1084
|
0
|
0
|
|
|
|
|
if (defined $hint{$key}) { |
1085
|
0
|
|
|
|
|
|
$flags |= $key_to_flag{$key}; |
1086
|
|
|
|
|
|
|
} else { |
1087
|
0
|
|
|
|
|
|
croak "Unrecognised WM_NORMAL_HINTS field: ",$key; |
1088
|
|
|
|
|
|
|
} |
1089
|
|
|
|
|
|
|
} |
1090
|
|
|
|
|
|
|
pack ('Lx16L13', |
1091
|
|
|
|
|
|
|
$flags, |
1092
|
|
|
|
|
|
|
$hint{'min_width'} || 0, # 1 |
1093
|
|
|
|
|
|
|
$hint{'min_height'} || 0, # 2 |
1094
|
|
|
|
|
|
|
$hint{'max_width'} || 0, # 3 |
1095
|
|
|
|
|
|
|
$hint{'max_height'} || 0, # 4 |
1096
|
|
|
|
|
|
|
$hint{'width_inc'} || 0, # 5 |
1097
|
|
|
|
|
|
|
$hint{'height_inc'} || 0, # 6 |
1098
|
|
|
|
|
|
|
_aspect (\%hint, 'min'), # 7,8 |
1099
|
|
|
|
|
|
|
_aspect (\%hint, 'max'), # 9,10 |
1100
|
|
|
|
|
|
|
$hint{'base_width'} || 0, # 11 |
1101
|
|
|
|
|
|
|
$hint{'base_height'} || 0, # 12 |
1102
|
0
|
|
0
|
|
|
|
$X->num('WinGravity',$hint{'win_gravity'} || 0), # 13 |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1103
|
|
|
|
|
|
|
); |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
sub _aspect { |
1107
|
0
|
|
|
0
|
|
|
my ($hint, $which) = @_; |
1108
|
0
|
0
|
|
|
|
|
if (defined (my $aspect = $hint->{"${which}_aspect"})) { |
1109
|
0
|
|
|
|
|
|
return aspect_to_num_den($aspect); |
1110
|
|
|
|
|
|
|
} else { |
1111
|
|
|
|
|
|
|
return ($hint->{"${which}_aspect_num"} || 0, |
1112
|
0
|
|
0
|
|
|
|
$hint->{"${which}_aspect_den"} || 0); |
|
|
|
0
|
|
|
|
|
1113
|
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
|
} |
1115
|
|
|
|
|
|
|
sub aspect_to_num_den { |
1116
|
0
|
|
|
0
|
1
|
|
my ($aspect) = @_; |
1117
|
|
|
|
|
|
|
### $aspect |
1118
|
|
|
|
|
|
|
|
1119
|
0
|
|
|
|
|
|
my ($num, $den); |
1120
|
|
|
|
|
|
|
|
1121
|
0
|
0
|
|
|
|
|
if ($aspect =~ /^\d+$/) { |
|
|
0
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
### integer |
1123
|
0
|
|
|
|
|
|
$num = $aspect; |
1124
|
0
|
|
|
|
|
|
$den = 1; |
1125
|
|
|
|
|
|
|
} elsif (($num,$den) = ($aspect =~ m{(.*)/(.*)})) { |
1126
|
|
|
|
|
|
|
### slash fraction |
1127
|
|
|
|
|
|
|
} else { |
1128
|
0
|
|
|
|
|
|
$num = $aspect; |
1129
|
0
|
|
|
|
|
|
$den = 1; |
1130
|
|
|
|
|
|
|
} |
1131
|
|
|
|
|
|
|
|
1132
|
0
|
|
|
|
|
|
my $den_zeros = 0; |
1133
|
0
|
0
|
|
|
|
|
if ($num =~ /^0*(\d*)\.(\d*?)0*$/) { |
1134
|
|
|
|
|
|
|
### decimal |
1135
|
0
|
|
|
|
|
|
$num = "$1$2"; |
1136
|
0
|
|
|
|
|
|
$den_zeros = length($2); |
1137
|
|
|
|
|
|
|
} |
1138
|
0
|
0
|
|
|
|
|
if ($den =~ /^0*(\d*)\.(\d*?)0*$/) { |
1139
|
|
|
|
|
|
|
### decimal |
1140
|
0
|
|
|
|
|
|
$den = "$1$2"; |
1141
|
0
|
|
|
|
|
|
$den_zeros -= length($2); |
1142
|
|
|
|
|
|
|
} |
1143
|
0
|
0
|
|
|
|
|
if ($den_zeros > 0) { |
1144
|
0
|
|
|
|
|
|
$den .= '0' x $den_zeros; |
1145
|
|
|
|
|
|
|
} |
1146
|
0
|
0
|
|
|
|
|
if ($den_zeros < 0) { |
1147
|
0
|
|
|
|
|
|
$num .= '0' x -$den_zeros; |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
|
1150
|
0
|
0
|
|
|
|
|
if ($num == $num-1) { # infinity |
1151
|
0
|
0
|
|
|
|
|
return (0x7FFF_FFFF, ($den == $den-1 # infinity too |
1152
|
|
|
|
|
|
|
? 0x7FFF_FFFF : 1)); |
1153
|
|
|
|
|
|
|
} |
1154
|
0
|
0
|
|
|
|
|
if ($den == $den-1) { # infinity |
1155
|
0
|
|
|
|
|
|
return (1, 0x7FFF_FFFF); |
1156
|
|
|
|
|
|
|
} |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
# cap anything bigger than 0x7FFFFFFF |
1159
|
0
|
0
|
0
|
|
|
|
if ($num >= $den && $num > 0x7FFF_FFFF) { |
1160
|
|
|
|
|
|
|
### reduce big numerator |
1161
|
0
|
|
|
|
|
|
($num,$den) = _aspect_reduce($num,$den); |
1162
|
|
|
|
|
|
|
} |
1163
|
0
|
0
|
|
|
|
|
if ($den > 0x7FFF_FFFF) { |
1164
|
|
|
|
|
|
|
### reduce big denominator |
1165
|
0
|
|
|
|
|
|
($den,$num) = _aspect_reduce($den,$num); |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
# increase non-integers in binary |
1169
|
0
|
|
0
|
|
|
|
while ((int($num) != $num || int($den) != $den) |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1170
|
|
|
|
|
|
|
&& $num < 0x4000_0000 |
1171
|
|
|
|
|
|
|
&& $den < 0x4000_0000) { |
1172
|
0
|
|
|
|
|
|
$num *= 2; |
1173
|
0
|
|
|
|
|
|
$den *= 2; |
1174
|
|
|
|
|
|
|
### up to: $num,$den |
1175
|
|
|
|
|
|
|
} |
1176
|
|
|
|
|
|
|
|
1177
|
0
|
|
|
|
|
|
return (_round_nz($num), _round_nz($den)); |
1178
|
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
# Return $x rounded to the nearest integer. |
1181
|
|
|
|
|
|
|
# If $x is not zero then the return is not zero too, ie. $x<0.5 is rounded |
1182
|
|
|
|
|
|
|
# up to return 1. |
1183
|
|
|
|
|
|
|
sub _round_nz { |
1184
|
0
|
|
|
0
|
|
|
my ($x) = @_; |
1185
|
0
|
|
|
|
|
|
my $nz = ($x != 0); |
1186
|
0
|
|
|
|
|
|
$x = int ($x + 0.5); |
1187
|
0
|
0
|
0
|
|
|
|
if ($nz && $x == 0) { |
1188
|
0
|
|
|
|
|
|
return 1; |
1189
|
|
|
|
|
|
|
} else { |
1190
|
0
|
|
|
|
|
|
return $x; |
1191
|
|
|
|
|
|
|
} |
1192
|
|
|
|
|
|
|
} |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
# $x is > 0x7FFF_FFFF. Reduce it to 0x7FFF_FFFF and reduce $y in proportion. |
1195
|
|
|
|
|
|
|
# If $y!=0 then it's reduced to a minimum 1, not to 0. |
1196
|
|
|
|
|
|
|
sub _aspect_reduce { |
1197
|
0
|
|
|
0
|
|
|
my ($x,$y) = @_; |
1198
|
0
|
|
|
|
|
|
my $nz = ($y != 0); |
1199
|
0
|
|
|
|
|
|
$y = int (0.5 + $y / $x * 0x7FFF_FFFF); |
1200
|
0
|
0
|
0
|
|
|
|
if ($nz && $y == 0) { $y = 1; } |
|
0
|
0
|
|
|
|
|
|
1201
|
0
|
|
|
|
|
|
elsif ($y > 0x7FFF_FFFF) { $y = 0x7FFF_FFFF; } |
1202
|
0
|
|
|
|
|
|
return (0x7FFF_FFFF, $y); |
1203
|
|
|
|
|
|
|
} |
1204
|
|
|
|
|
|
|
# printf "%d %d", _aspect_frac('.123456789'); |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
1; |
1209
|
|
|
|
|
|
|
__END__ |