Skip to content
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
Cannot retrieve contributors at this time
;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
;;; Implementation of the XTest extension as described by
;;; Written by Lionel Flandrin <> in july
;;; 2008 and placed in the public domain.
;;; TODO:
;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard
;;; * Add the missing (declare (type ...
(defpackage #:xlib/xtest
(:use :common-lisp :xlib)
(:import-from :xlib
;; Constants
;; Functions
(in-package #:xlib/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: