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
|
;; Copyright (C) 2003-2008 Shawn Betts
;;
;; This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;; Commentary:
;;
;; This file contains core functionality including functions on
;; windows, screens, and events.
;;
;; Code:
(in-package :stumpwm)
;; Wow, is there an easier way to do this?
(defmacro def-thing-attr-macro (thing hash-slot)
(let ((attr (gensym "ATTR"))
(obj (gensym "METAOBJ"))
(val (gensym "METAVAL")))
`(defmacro ,(intern1 (format nil "DEF-~a-ATTR" thing)) (,attr)
"Create a new attribute and corresponding get/set functions."
(let ((,obj (gensym "OBJ"))
(,val (gensym "VAL")))
`(progn
(defun ,(intern1 (format nil ,(format nil "~a-~~a" thing) ,attr)) (,,obj)
(gethash ,,attr (,(quote ,hash-slot) ,,obj)))
(defun (setf ,(intern1 (format nil ,(format nil "~a-~~a" thing) ,attr))) (,,val ,,obj)
(setf (gethash ,,attr (,(quote ,hash-slot) ,,obj))) ,,val))))))
;;; keyboard helper functions
(defun key-to-keycode+state (key)
(let ((code (xlib:keysym->keycodes *display* (key-keysym key))))
(cond ((eq (xlib:keycode->keysym *display* code 0) (key-keysym key))
(values code (x11-mods key)))
((eq (xlib:keycode->keysym *display* code 1) (key-keysym key))
(values code (apply 'xlib:make-state-mask
(cons :shift (xlib:make-state-keys (x11-mods key))))))
(t
;; just warn them and go ahead as scheduled
(warn "Don't know how to encode ~s" key)
(values code (x11-mods key))))))
(defun send-fake-key (win key)
"Send a fake key press event to win."
(multiple-value-bind (code state) (key-to-keycode+state key)
(xlib:send-event (window-xwin win) :key-press (xlib:make-event-mask :key-press)
:display *display*
:root (screen-root (window-screen win))
;; Apparently we need these in here, though they
;; make no sense for a key event.
:x 0 :y 0 :root-x 0 :root-y 0
:window (window-xwin win) :event-window (window-xwin win)
:code code
:state state)))
(defun send-fake-click (win button)
"Send a fake click (button press + button release) to win."
(cond
#+clx-ext-test
((xlib:query-extension *display* "XTEST")
(xtest:fake-button-event *display* button t)
(xtest:fake-button-event *display* button nil))
(t
(multiple-value-bind (x y) (xlib:query-pointer (window-xwin win))
(multiple-value-bind (rx ry) (xlib:query-pointer (screen-root (window-screen win)))
(xlib:send-event (window-xwin win) :button-press (xlib:make-event-mask :button-press)
:display *display*
:root (screen-root (window-screen win))
:window (window-xwin win) :event-window (window-xwin win)
:code button
:state 0
:x x :y y :root-x rx :root-y ry
:same-screen-p t)
(xlib:send-event (window-xwin win) :button-release (xlib:make-event-mask :button-release)
:display *display*
:root (screen-root (window-screen win))
:window (window-xwin win) :event-window (window-xwin win)
:code button
:state #x100
:x x :y y :root-x rx :root-y ry
:same-screen-p t))))))
;;; Pointer helper functions
(defun grab-pointer (screen)
"Grab the pointer and set the pointer shape."
(incf *grab-pointer-count*)
(let* ((cursor-font (xlib:open-font *display* *grab-pointer-font*))
(cursor (xlib:create-glyph-cursor :source-font cursor-font
:source-char *grab-pointer-character*
:mask-font cursor-font
:mask-char *grab-pointer-character-mask*
:foreground *grab-pointer-foreground*
:background *grab-pointer-background*)))
(xlib:grab-pointer (screen-root screen) nil :owner-p nil
:cursor cursor)))
(defun ungrab-pointer ()
"Remove the grab on the cursor and restore the cursor shape."
(when (> *grab-pointer-count* 0) (decf *grab-pointer-count*))
(when (eq *grab-pointer-count* 0)
(xlib:ungrab-pointer *display*)
(xlib:display-finish-output *display*)))
(defun grab-keyboard (xwin)
(let ((ret (xlib:grab-keyboard xwin :owner-p nil
:sync-keyboard-p nil :sync-pointer-p nil)))
(dformat 5 "vvv Grab keyboard: ~s~%" ret)
ret))
(defun ungrab-keyboard ()
(let ((ret (xlib:ungrab-keyboard *display*)))
(dformat 5 "^^^ Ungrab keyboard: ~s~%" ret)
ret))
(defun warp-pointer (screen x y)
"Move the pointer to the specified location."
(let ((root (screen-root screen)))
(xlib:warp-pointer root x y)))
(defun warp-pointer-relative (dx dy)
"Move the pointer by DX and DY relative to the current location."
(xlib:warp-pointer-relative *display* dx dy))
|
