1#!/usr/local/bin/perl -w 2 3# Copyright 2011, 2012, 2013 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 20 21# Usage: perl xfixes-cursor-image.pl 22# 23# This is an example of getting the mouse pointer cursor image with XFIXES. 24# 25# $X->XFixesGetCursorImage() retrieves the cursor image. CursorNotify 26# events report when the image changes. A change is normally due to moving 27# into a window with a different "cursor" attribute, but may also be a 28# pointer grab, or even an animated changing cursor from the RENDER 29# extension. See cursor-font-anim.pl for some fun with an animated root 30# window cursor. 31# 32# The only painful thing is that XFixesGetCursorImage() gives 8-bit RGBA, so 33# it's necessary to allocate colours etc to display that in a window. In 34# the code here the image is drawn to a pixmap, then that pixmap drawn to 35# the window under Expose. 36# 37# $X->XFixesGetCursorImage() isn't done in the "event_handler" code because 38# it's a round-trip request and waiting for the reply might read new events 39# and call the event_handler recursively. If badly lagged and continually 40# receiving CursorNotify then that could be a very deep recursion, or make a 41# mess of the drawing code. So the event_handler just notes a fresh 42# XFixesGetCursorImage() is required and that's done in the main loop after 43# $X->handle_input(). 44# 45# With only the core X protocol there's no good way to get the current 46# cursor or its image. The cursor attribute on a window can't be read back 47# with GetWindowAttributes(), and all the area copying things such as 48# GetImage() ignore the cursor. 49# 50# Things Not Done: 51# 52# The display window is a fixed 63x63 and the image positioned so the 53# hotspot is always at 31,31. This fits a cursor of up to 32x32. A real 54# program might centre the hotspot in the current window size (listening to 55# ConfigureNotify), and might make the pixmap only the size of the cursor 56# then draw it at the right place. 57# 58# The ChangeGC() plus PolyPoint() for each pixel is a bit wasteful. Better 59# would be to send all the pixels in one PutImage(), but building the 60# server's required bit units, byte order and padding is a bit like hard 61# work. 62# 63# The alpha channel in the cursor image is only used to draw or not draw 64# each pixel. It could be combined with the grey window background without 65# too much trouble. What's the right multiplication for alpha weighting? 66# In core protocol the cursor pixels are always fully-opaque or 67# fully-transparent, but XFIXES can make partial-transparent cursors. 68# 69 70use 5.004; 71use strict; 72use X11::Protocol; 73use X11::AtomConstants; 74use X11::Protocol::WM; 75 76# uncomment this to run the ### lines 77#use Smart::Comments; 78 79my $X = X11::Protocol->new; 80if (! $X->init_extension('XFIXES')) { 81 print "XFIXES extension not available on the server\n"; 82 exit 1; 83} 84 85my $colormap = $X->default_colormap; 86 87# rgb8_to_pixel() takes colour components 0 to 255 and returns a pixel value 88# suitable for $window and $pixmap. Black and white pixel values from the 89# $X screen info are pre-loaded, other colours have to be allocated. 90# 91my %allocated_pixels = ('0.0.0' => $X->black_pixel, 92 '255.255.255' => $X->white_pixel); 93sub rgb8_to_pixel { 94 my ($red, $green, $blue) = @_; 95 my $key = "$red.$green.$blue"; 96 my $pixel = $allocated_pixels{$key}; 97 if (! defined $pixel) { 98 ($pixel) = $X->AllocColor ($colormap, 99 $red * 0x101, $green * 0x101, $blue * 0x101); 100 $allocated_pixels{$key} = $pixel; 101 } 102 return $pixel; 103} 104 105# grey colour 106my ($background_pixel) =$X->AllocColor ($colormap, 0x9000,0x9000,0x9000); 107 108my $window = $X->new_rsrc; 109$X->CreateWindow ($window, 110 $X->root, # parent 111 'InputOutput', # class 112 $X->root_depth, # depth 113 'CopyFromParent', # visual 114 0,0, # x,y 115 63,63, # w,h initial size 116 0, # border 117 background_pixel => $background_pixel, 118 event_mask => $X->pack_event_mask('Exposure'), 119 ); 120X11::Protocol::WM::set_wm_name ($X, $window, 'Current Cursor'); # title 121X11::Protocol::WM::set_wm_icon_name ($X, $window, 'Cursor'); 122X11::Protocol::WM::set_wm_client_machine_from_syshostname ($X, $window); 123X11::Protocol::WM::set_net_wm_pid ($X, $window); 124 125my $pixmap = $X->new_rsrc; 126$X->CreatePixmap ($pixmap, 127 $window, 128 $X->root_depth, 129 63,63); # width,height 130 131my $gc = $X->new_rsrc; 132$X->CreateGC ($gc, $pixmap, 133 # don't want NoExpose events when copying from $pixmap 134 graphics_exposures => 0); 135 136 137my $want_get_image = 1; 138my $current_cursor_serial = -1; 139 140$X->{'event_handler'} = sub { 141 my (%h) = @_; 142 ### event_handler: \%h 143 144 if ($h{'name'} eq 'XFixesCursorNotify') { 145 if ($h{'cursor_serial'} != $current_cursor_serial) { 146 $want_get_image = 1; 147 } 148 149 } elsif ($h{'name'} eq 'Expose') { 150 $X->CopyArea ($pixmap, $window, $gc, 151 0,0, # src x,y 152 63,63, # src w,h 153 0,0); # dst x,y 154 } 155}; 156 157$X->XFixesSelectCursorInput ($window, 1); 158$X->MapWindow($window); 159 160for (;;) { 161 $X->handle_input; 162 163 if ($want_get_image) { 164 my ($root_x,$root_y, $width,$height, $xhot,$yhot, $serial, $cursor_pixels) 165 = $X->XFixesGetCursorImage; 166 $current_cursor_serial = $serial; 167 168 $X->ChangeGC ($gc, foreground => $background_pixel); 169 $X->PolyFillRectangle ($pixmap, $gc, [0,0, 63,63]); 170 171 my $pos = 0; 172 foreach my $y (0 .. $height-1) { 173 foreach my $x (0 .. $width-1) { 174 175 my $argb = unpack 'L', substr($cursor_pixels,$pos,4); 176 my $alpha = ($argb >> 24) & 0xFF; 177 my $red = ($argb >> 16) & 0xFF; 178 my $green = ($argb >> 8) & 0xFF; 179 my $blue = $argb & 0xFF; 180 $pos += 4; 181 182 if ($alpha >= 128) { # opaque, ie. not transparent 183 my $pixmap_pixel = rgb8_to_pixel($red, $green, $blue); 184 $X->ChangeGC ($gc, foreground => $pixmap_pixel); 185 $X->PolyPoint ($pixmap, $gc, 'Origin', 186 # hotspot at position x=31,y=31 in the display 187 $x + 31-$xhot, 188 $y + 31-$yhot); 189 } 190 } 191 } 192 $X->CopyArea ($pixmap, $window, $gc, 193 0,0, # src x,y 194 63,63, # src w,h 195 0,0); # dst x,y 196 197 # print "Cursor size ${width}x${height}\n"; 198 } 199} 200 201exit 0; 202