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