/[cmucl]/src/clx/xtest.lisp
ViewVC logotype

Contents of /src/clx/xtest.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-base, sparc-tramp-assem-base, post-merge-intl-branch, snapshot-2010-12, snapshot-2010-11, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, intl-2-branch-base, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, release-20a-pre1, snapshot-2009-11, snapshot-2010-06, pre-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, intl-branch-working-2010-02-11-1000, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, cross-sparc-branch-base, intl-branch-base, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, sparc-tramp-assem-2010-07-19, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, snapshot-2009-08, release-20a-base, snapshot-2009-07, RELEASE_20b, RELEASE_20a, cross-sol-x86-2010-12-20, amd64-dd-start, intl-branch-2010-03-18-1300, snapshot-2009-12, HEAD
Branch point for: RELEASE-20A-BRANCH, unicode-string-buffer-branch, cross-sol-x86-branch, cross-sparc-branch, sparc-tramp-assem-branch, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-2-branch, RELEASE-20B-BRANCH, intl-branch
Changes since 1.1: +154 -0 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
2 ;;;
3 ;;; Implementation of the XTest extension as described by
4 ;;; http://www.x.org/docs/Xext/xtest.pdf
5 ;;;
6 ;;; Written by Lionel Flandrin <lionel.flandrin@gmail.com> in july
7 ;;; 2008 and placed in the public domain.
8 ;;;
9 ;;; TODO:
10 ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard
11 ;;; * Add the missing (declare (type ...
12
13 (defpackage :xtest
14 (:use :common-lisp :xlib)
15 (:import-from :xlib
16 #:data
17 #:card8
18 #:card8-get
19 #:card16
20 #:card16-get
21 #:card32
22 #:card32-get
23 #:extension-opcode
24 #:define-extension
25 #:gcontext
26 #:resource-id
27 #:window-id
28 #:cursor
29 #:make-cursor
30 #:with-buffer-request-and-reply
31 #:with-buffer-request
32 #:display)
33 (:export
34 ;; Constants
35 #:+major-version+
36 #:+minor-version+
37
38 ;; Functions
39 #:set-gc-context-of-gc
40 #:get-version
41 #:compare-cursor
42 #:fake-motion-event
43 #:fake-button-event
44 #:fake-key-event
45 #:grab-control))
46
47 (in-package :xtest)
48
49 (define-extension "XTEST")
50
51 (defmacro opcode (display)
52 `(extension-opcode ,display "XTEST"))
53
54 ;;; The version we implement
55 (defconstant +major-version+ 2)
56 (defconstant +minor-version+ 2)
57
58 (defconstant +none+ 0)
59 (defconstant +current-cursor+ 1)
60
61 ;;; XTest opcodes
62 (defconstant +get-version+ 0)
63 (defconstant +compare-cursor+ 1)
64 (defconstant +fake-input+ 2)
65 (defconstant +grab-control+ 3)
66
67 ;;; Fake events
68 (defconstant +fake-key-press+ 2)
69 (defconstant +fake-key-release+ 3)
70 (defconstant +fake-button-press+ 4)
71 (defconstant +fake-button-release+ 5)
72 (defconstant +fake-motion-notify+ 6)
73
74 ;;; Client operations
75 (defun set-gc-context-of-gc (gcontext gcontext-id)
76 (declare (type gcontext gcontext)
77 (type resource-id gcontext-id))
78 (setf (gcontext-id gcontext) gcontext-id))
79
80 ;;; Server requests
81 (defun get-version (display &optional (major +major-version+) (minor +minor-version+))
82 "Returns the major and minor version of the server's XTest implementation"
83 (declare (type display display))
84 (with-buffer-request-and-reply (display (opcode display) nil)
85 ((data +get-version+)
86 (card8 major)
87 (card16 minor))
88 (values (card8-get 1)
89 (card16-get 8))))
90
91 (defun compare-cursor (display window &optional (cursor-id +current-cursor+))
92 (declare (type display display)
93 (type resource-id cursor-id)
94 (type window window))
95 (with-buffer-request-and-reply (display (opcode display) nil)
96 ((data +compare-cursor+)
97 (resource-id (window-id window))
98 (resource-id cursor-id))
99 (values (card8-get 1))))
100
101 (defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0))
102 "Move the mouse pointer at coordinates (x, y). If :relative is t,
103 the movement is relative to the pointer's current position"
104 (declare (type display display))
105 (with-buffer-request (display (opcode display))
106 (data +fake-input+)
107 (card8 +fake-motion-notify+)
108 (card8 (if relative 1 0))
109 (pad16 0)
110 (card32 delay)
111 (card32 root-window-id)
112 (pad32 0 0)
113 (card16 x)
114 (card16 y)
115 (pad32 0 0)))
116
117 (defun fake-button-event (display button pressed &key (delay 0))
118 "Send a fake button event (button pressed or released) to the
119 server. Most of the time, button 1 is the left one, 2 the middle and 3
120 the right one but it's not always the case."
121 (declare (type display display))
122 (with-buffer-request (display (opcode display))
123 (data +fake-input+)
124 (card8 (if pressed +fake-button-press+ +fake-button-release+))
125 (card8 button)
126 (pad16 0)
127 (card32 delay)
128 (pad32 0 0 0 0 0 0)))
129
130 (defun fake-key-event (display keycode pressed &key (delay 0))
131 "Send a fake key event (key pressed or released) to the server based
132 on its keycode."
133 (declare (type display display))
134 (with-buffer-request (display (opcode display))
135 (data +fake-input+)
136 (card8 (if pressed +fake-key-press+ +fake-key-release+))
137 (card8 keycode)
138 (pad16 0)
139 (card32 delay)
140 (pad32 0 0 0 0 0 0)))
141
142 (defun grab-control (display grab?)
143 "Make the client grab the server, that is allow it to make requests
144 even when another client grabs the server."
145 (declare (type display display))
146 (with-buffer-request (display (opcode display))
147 (data +grab-control+)
148 (card8 (if grab? 1 0))
149 (pad8 0)
150 (pad16 0)))
151
152 ;;; Local Variables:
153 ;;; indent-tabs-mode: nil
154 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5