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