/usr/share/common-lisp/source/clx/xtest.lisp is in cl-clx-sbcl 0.7.4-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Implementation of the XTest extension as described by
;;; http://www.x.org/docs/Xext/xtest.pdf
;;;
;;; Written by Lionel Flandrin <lionel.flandrin@gmail.com> in july
;;; 2008 and placed in the public domain.
;;;
;;; TODO:
;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard
;;; * Add the missing (declare (type ...
(defpackage :xtest
(:use :common-lisp :xlib)
(:import-from :xlib
#:data
#:card8
#:card8-get
#:card16
#:card16-get
#:card32
#:card32-get
#:extension-opcode
#:define-extension
#:gcontext
#:resource-id
#:window-id
#:cursor
#:make-cursor
#:with-buffer-request-and-reply
#:with-buffer-request
#:display)
(:export
;; Constants
#:+major-version+
#:+minor-version+
;; Functions
#:set-gc-context-of-gc
#:get-version
#:compare-cursor
#:fake-motion-event
#:fake-button-event
#:fake-key-event
#:grab-control))
(in-package :xtest)
(define-extension "XTEST")
(defmacro opcode (display)
`(extension-opcode ,display "XTEST"))
;;; The version we implement
(defconstant +major-version+ 2)
(defconstant +minor-version+ 2)
(defconstant +none+ 0)
(defconstant +current-cursor+ 1)
;;; XTest opcodes
(defconstant +get-version+ 0)
(defconstant +compare-cursor+ 1)
(defconstant +fake-input+ 2)
(defconstant +grab-control+ 3)
;;; Fake events
(defconstant +fake-key-press+ 2)
(defconstant +fake-key-release+ 3)
(defconstant +fake-button-press+ 4)
(defconstant +fake-button-release+ 5)
(defconstant +fake-motion-notify+ 6)
;;; Client operations
(defun set-gc-context-of-gc (gcontext gcontext-id)
(declare (type gcontext gcontext)
(type resource-id gcontext-id))
(setf (gcontext-id gcontext) gcontext-id))
;;; Server requests
(defun get-version (display &optional (major +major-version+) (minor +minor-version+))
"Returns the major and minor version of the server's XTest implementation"
(declare (type display display))
(with-buffer-request-and-reply (display (opcode display) nil)
((data +get-version+)
(card8 major)
(card16 minor))
(values (card8-get 1)
(card16-get 8))))
(defun compare-cursor (display window &optional (cursor-id +current-cursor+))
(declare (type display display)
(type resource-id cursor-id)
(type window window))
(with-buffer-request-and-reply (display (opcode display) nil)
((data +compare-cursor+)
(resource-id (window-id window))
(resource-id cursor-id))
(values (card8-get 1))))
(defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0))
"Move the mouse pointer at coordinates (x, y). If :relative is t,
the movement is relative to the pointer's current position"
(declare (type display display))
(with-buffer-request (display (opcode display))
(data +fake-input+)
(card8 +fake-motion-notify+)
(card8 (if relative 1 0))
(pad16 0)
(card32 delay)
(card32 root-window-id)
(pad32 0 0)
(card16 x)
(card16 y)
(pad32 0 0)))
(defun fake-button-event (display button pressed &key (delay 0))
"Send a fake button event (button pressed or released) to the
server. Most of the time, button 1 is the left one, 2 the middle and 3
the right one but it's not always the case."
(declare (type display display))
(with-buffer-request (display (opcode display))
(data +fake-input+)
(card8 (if pressed +fake-button-press+ +fake-button-release+))
(card8 button)
(pad16 0)
(card32 delay)
(pad32 0 0 0 0 0 0)))
(defun fake-key-event (display keycode pressed &key (delay 0))
"Send a fake key event (key pressed or released) to the server based
on its keycode."
(declare (type display display))
(with-buffer-request (display (opcode display))
(data +fake-input+)
(card8 (if pressed +fake-key-press+ +fake-key-release+))
(card8 keycode)
(pad16 0)
(card32 delay)
(pad32 0 0 0 0 0 0)))
(defun grab-control (display grab?)
"Make the client grab the server, that is allow it to make requests
even when another client grabs the server."
(declare (type display display))
(with-buffer-request (display (opcode display))
(data +grab-control+)
(card8 (if grab? 1 0))
(pad8 0)
(pad16 0)))
;;; Local Variables:
;;; indent-tabs-mode: nil
;;; End:
|