1#!/usr/bin/perl -w
2
3# Copyright 2011, 2012, 2013, 2014, 2018, 2019 Kevin Ryde
4
5# This file is part of X11-Protocol-Other.
6#
7# X11-Protocol-Other is free software; you can redistribute it and/or
8# modify it under the terms of the GNU General Public License as published
9# by the Free Software Foundation; either version 3, or (at your option) any
10# later version.
11#
12# X11-Protocol-Other is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
15# Public License for more details.
16#
17# You should have received a copy of the GNU General Public License along
18# with X11-Protocol-Other.  If not, see <http://www.gnu.org/licenses/>.
19
20use 5.004;
21use strict;
22use X11::Protocol;
23use X11::Protocol::WM;
24$|=1;
25
26# uncomment this to run the ### lines
27use Smart::Comments;
28
29
30{
31  # sample code in the POD
32
33  my $display = $ENV{DISPLAY} || ':0';
34  my $X = X11::Protocol->new ($display);
35    my @net_supported = X11::Protocol::Other::get_property_atoms
36                         ($X, $X->root, $X->atom('_NET_SUPPORTED'));
37    if (grep {$_ == $X->atom('_NET_WM_STATE_FULLSCREEN')}
38             @net_supported) {
39      print "Have _NET_WM_STATE_FULLSCREEN\n";
40    } else {
41      print "Do not have _NET_WM_STATE_FULLSCREEN\n";
42    }
43
44  exit 0;
45}
46{
47  # Maybe:
48  my $display = $ENV{DISPLAY} || ':0';
49  my $X = X11::Protocol->new ($display);
50
51  system('xprop','-d',$display,'-root','_NET_SUPPORTED');
52
53  my @supported = X11::Protocol::Other::get_property_atoms ($X, $X->root, $X->atom('_NET_SUPPORTED'));
54  ### len: scalar(@supported)
55  ### @supported
56  foreach my $atom (@supported) {
57    print $X->atom_name($atom),"\n";
58  }
59
60  @supported = X11::Protocol::Other::get_property_atoms ($X, $X->root, $X->atom('NOSUCH'));
61  ### len: scalar(@supported)
62
63  @supported = X11::Protocol::Other::get_property_atoms ($X, 0xa0001b, $X->atom('_NET_SUPPORTED'));
64  ### len: scalar(@supported)
65
66  exit 0;
67}
68{
69  # urgency hint
70  # cf fvwm hints_test.c program for making a window with some hints
71
72  my $X = X11::Protocol->new (':0');
73  my $window = $X->new_rsrc;
74  $X->CreateWindow ($window,
75                    $X->root,         # parent
76                    'InputOutput',
77                    0,                # depth, from parent
78                    'CopyFromParent', # visual
79                    0,0,              # x,y
80                    100,100,          # width,height
81                    0,                # border
82                    background_pixel => $X->black_pixel,
83                   );
84  $X->MapWindow ($window);
85  $X->QueryPointer($X->root); # sync
86  sleep 1;
87  X11::Protocol::WM::set_wm_hints ($X, $window,
88                                   # input => 1,
89                                   urgency => 1);
90  $X->QueryPointer($X->root); # sync
91  sleep 30;
92  print "urgency\n";
93  X11::Protocol::WM::change_wm_hints ($X, $window, urgency => 1);
94  # $X->QueryPointer($X->root); # sync
95  $X->flush;
96  sleep 30;
97
98  # my %hints = X11::Protocol::WM::get_wm_hints($X,$window);
99  # ### %hints
100
101  exit 0;
102}
103
104{
105  my $X = X11::Protocol->new ($ENV{DISPLAY} || ':0');
106  $X->MapWindow($ARGV[0] || $ENV{WINDOWID});
107  $X->QueryPointer($X->root); # sync
108  exit 0;
109}
110
111{
112  # apply _NET_WM_STATE change
113  my $X = X11::Protocol->new (':0');
114
115  {
116    my ($value, $type, $format, $bytes_after)
117      = $X->GetProperty ($X->root, $X->atom('_NET_SUPPORTED'),
118                         0,    # AnyPropertyType
119                         0,    # offset
120                         999,  # length
121                         0);   # delete;
122    foreach my $atom (unpack('L*', $value)) {
123      my $atom_name = $X->atom_name($atom);
124      if ($atom_name =~ /STATE/) {
125        print "$atom_name\n";
126      }
127    }
128  }
129
130  my $window = $ARGV[0] || do {
131    print "click to choose window\n";
132    require X11::Protocol::ChooseWindow;
133    X11::Protocol::ChooseWindow->choose(X=>$X)
134    };
135  X11::Protocol::WM::change_net_wm_state
136      ($X,$window,'toggle',
137       # '_NET_WM_STATE_MAXIMIZED_SKIP_TASKBAR',
138        '_NET_WM_STATE_MAXIMIZED_VERT',
139       # state2 => '_NET_WM_STATE_MAXIMIZED_HORZ',
140      );
141  # '_NET_WM_STATE_FULLSCREEN',
142  $X->flush;
143  sleep 1;
144  { my @states = X11::Protocol::WM::get_net_wm_state($X,$window);
145    ### @states
146  }
147  { my @atoms = X11::Protocol::WM::get_net_wm_state_atoms($X,$window);
148    ### @atoms
149  }
150  system ("xprop -id $window | grep STATE");
151  exit 0;
152}
153{
154  # default WM_HINTS
155
156  my $X = X11::Protocol->new;
157  my $window = $X->new_rsrc;
158  $X->CreateWindow ($window,
159                    $X->root,         # parent
160                    'InputOutput',
161                    0,                # depth, from parent
162                    'CopyFromParent', # visual
163                    0,0,              # x,y
164                    100,100,          # width,height
165                    0,                # border
166                    background_pixel => $X->black_pixel,
167                   );
168  $X->MapWindow ($window);
169  $X->QueryPointer($X->root); # sync
170  sleep 100;
171  exit 0;
172}
173
174{
175  # withdraw()
176
177  my $X = X11::Protocol->new;
178
179  my $event = $X->pack_event (name           => 'UnmapNotify',
180                              event          => $X->root,
181                              window         => $X->root,
182                              from_configure => 0);
183  ### $event
184
185  my $window = $X->new_rsrc;
186  $X->CreateWindow ($window,
187                    $X->root,         # parent
188                    'InputOutput',
189                    0,                # depth, from parent
190                    'CopyFromParent', # visual
191                    0,0,              # x,y
192                    100,100,          # width,height
193                    0,                # border
194                    background_pixel => $X->black_pixel,
195                   );
196  $X->MapWindow ($window);
197  $X->QueryPointer($X->root); # sync
198  sleep 1;
199  print "iconify\n";
200  X11::Protocol::WM::iconify($X,$window);
201  $X->QueryPointer($X->root); # sync
202  sleep 1;
203  print "withdraw\n";
204  X11::Protocol::WM::withdraw($X,$window);
205  $X->QueryPointer($X->root); # sync
206  sleep 1;
207
208  exit 0;
209}
210
211{
212  # _NET_VIRTUAL_ROOTS
213
214  my $X = X11::Protocol->new;
215  my $atom = $X->atom('_NET_VIRTUAL_ROOTS');
216  my ($value, $type, $format, $bytes_after)
217    = $X->GetProperty ($X->root, $atom,
218                       0,    # AnyPropertyType
219                       0,    # offset
220                       999,  # length
221                       0);   # delete;
222  ### $value, $type, $format, $bytes_after)
223  ### $value
224  ### $type
225  ### $format
226  ### $bytes_after
227  exit 0;
228}
229
230{
231  # WM_CHANGE_STATE exists
232  my $X = X11::Protocol->new;
233  my $atom = $X->InternAtom("WM_CHANGE_STATE",1);
234  ### $atom
235  exit 0;
236}
237
238
239{
240  # get_net_frame_extents()
241
242  my $X = X11::Protocol->new;
243
244  my $window = $X->new_rsrc;
245  $X->CreateWindow ($window,
246                    $X->root,         # parent
247                    'InputOutput',
248                    0,                # depth, from parent
249                    'CopyFromParent', # visual
250                    0,0,              # x,y
251                    100,100,          # width,height
252                    0,                # border
253                    background_pixel => $X->black_pixel,
254                   );
255  $X->MapWindow ($window);
256  $X->flush;
257  sleep 1;
258  my @extents = X11::Protocol::WM::get_net_frame_extents ($X, $window);
259  ### @extents
260  exit 0;
261}
262
263{
264  my $X = X11::Protocol->new;
265
266  my $window = $X->new_rsrc;
267  $X->CreateWindow ($window,
268                    $X->root,         # parent
269                    'InputOutput',
270                    0,                # depth, from parent
271                    'CopyFromParent', # visual
272                    0,0,              # x,y
273                    100,100,          # width,height
274                    0,                # border
275                    background_pixel => $X->black_pixel,
276                   );
277  X11::Protocol::WM::set_wm_name ($X, $window, "\x{2202}");
278  # require Encode;
279  # $x->changeproperty($window,
280  #                    $X->atom('_NET_WM_NAME'),
281  #                    $X->atom('UTF8_STRING'),   # type
282  #                    8,                         # byte format
283  #                    'Replace',
284  #                    Encode::encode_utf8("\x{2202}"));
285  $X->MapWindow ($window);
286
287  for (;;) { $X->handle_input }
288  exit 0;
289}
290
291{
292  require Gtk2;
293  Gtk2->init;
294  my $toplevel = Gtk2::Window->new;
295  $toplevel->set_title ("\x{2202}");
296  $toplevel->show;
297  $toplevel->get_display->flush;
298
299  my $X = X11::Protocol->new;
300  my $root = $X->{'root'};
301  my ($root_root, $root_parent, @toplevels) = $X->QueryTree($root);
302  ### $root_root
303  ### $root_parent
304  foreach my $window ($toplevel->window->XID,
305                      # @toplevels
306                     ) {
307    ### window: sprintf '%X', $window
308
309    if (1) {
310      my @atoms = $X->ListProperties ($window);
311      foreach my $atom (@atoms) {
312        my ($value, $type, $format, $bytes_after)
313          = $X->GetProperty ($window,
314                             $atom,
315                             0,  # AnyPropertyType
316                             0,  # offset
317                             0x7FFF_FFFF,  # length
318                             0); # delete
319        if (length($value)) {
320          ### atom: $X->atom_name($atom)
321          ### window: sprintf '%X', $window
322          ### $value
323          ### $type
324          ### type: $type && $X->atom_name($type)
325          ### $format
326          ### $bytes_after
327          # my @atoms = unpack 'L*', $value;
328          # foreach my $atom (@atoms) {
329          #   ### atom: $X->atom_name($atom)
330          # }
331
332          if ($type == $X->atom('ATOM')) {
333            foreach my $at (unpack 'L*', $value) {
334              ### atom: $X->atom_name($at)
335            }
336          }
337        }
338      }
339    }
340
341    if (0) {
342      my ($value, $type, $format, $bytes_after)
343        = $X->GetProperty ($window,
344                           $X->atom('WM_PROTOCOLS'),
345                           0,  # AnyPropertyType
346                           0,  # offset
347                           1,  # length
348                           0); # delete
349      ### $value
350      ### $type
351      ### type: $type && $X->atom_name($type)
352      ### $format
353      ### $bytes_after
354      my @atoms = unpack 'L*', $value;
355      foreach my $atom (@atoms) {
356        ### atom: $X->atom_name($atom)
357      }
358    }
359    if (0) {
360      my ($value, $type, $format, $bytes_after)
361        = $X->GetProperty ($window,
362                           $X->atom('WM_HINTS'),
363                           0,  # AnyPropertyType
364                           0,  # offset
365                           1,  # length
366                           0); # delete
367      if (length($value)) {
368        ### WM_HINTS
369        ### window: sprintf '%X', $window
370        ### $value
371        ### $type
372        ### type: $type && $X->atom_name($type)
373        ### $format
374        ### $bytes_after
375        # my @atoms = unpack 'L*', $value;
376        # foreach my $atom (@atoms) {
377        #   ### atom: $X->atom_name($atom)
378        # }
379      }
380    }
381
382    if (0) {
383      my ($value, $type, $format, $bytes_after)
384        = $X->GetProperty ($window,
385                           $X->atom('WM_NORMAL_HINTS'),
386                           0,  # AnyPropertyType
387                           0,  # offset
388                           1,  # length
389                           0); # delete
390      if (length($value)) {
391        ### WM_NORMAL_HINTS
392        ### window: sprintf '%X', $window
393        ### $value
394        ### value length: length($value)
395        ### $type
396        ### type: $type && $X->atom_name($type)
397        ### $format
398        ### $bytes_after
399        # my @atoms = unpack 'L*', $value;
400        # foreach my $atom (@atoms) {
401        #   ### atom: $X->atom_name($atom)
402        # }
403      }
404    }
405  }
406
407  # ### nosuch: $X->atom_name(73281947)
408  exit 0;
409}
410
411
412