1;; decode-events.jl -- symbolic event manipulation 2 3;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk> 4 5;; This file is part of sawfish. 6 7;; sawfish is free software; you can redistribute it and/or modify it 8;; under the terms of the GNU General Public License as published by 9;; the Free Software Foundation; either version 2, or (at your option) 10;; any later version. 11 12;; sawfish is distributed in the hope that it will be useful, but 13;; WITHOUT ANY WARRANTY; without even the implied warranty of 14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15;; GNU General Public License for more details. 16 17;; You should have received a copy of the GNU General Public License 18;; along with sawfish; see the file COPYING. If not, write to 19;; the Free Software Foundation, 51 Franklin Street, Fifth Floor, 20;; Boston, MA 02110-1301 USA. 21 22(define-structure sawfish.wm.util.decode-events 23 24 (export decode-modifier 25 encode-modifier 26 substitute-wm-modifier 27 decode-event 28 encode-event 29 string->keysym 30 modifier->keysyms 31 modifier-keysym-p 32 should-grab-button-event-p) 33 34 (open rep 35 sawfish.wm.events) 36 37 (define-structure-alias decode-events sawfish.wm.util.decode-events) 38 39 (define (decode-modifier mods) 40 (let ((out '())) 41 (do ((i 0 (1+ i))) 42 ((= i 13)) 43 (when (not (zerop (logand mods (lsh 1 i)))) 44 (setq out (cons (aref [shift lock control mod-1 mod-2 45 mod-3 mod-4 mod-5 button-1 46 button-2 button-3 button-4 47 button-5] i) out)))) 48 (when (not (zerop (logand mods (lsh 1 20)))) 49 (setq out (cons 'meta out))) 50 (when (not (zerop (logand mods (lsh 1 21)))) 51 (setq out (cons 'alt out))) 52 (when (not (zerop (logand mods (lsh 1 24)))) 53 (setq out (cons 'hyper out))) 54 (when (not (zerop (logand mods (lsh 1 25)))) 55 (setq out (cons 'super out))) 56 (when (not (zerop (logand mods (lsh 1 26)))) 57 (setq out (cons 'wm out))) 58 (when (not (zerop (logand mods (lsh 1 22)))) 59 (setq out (cons 'any out))) 60 (when (not (zerop (logand mods (lsh 1 23)))) 61 (setq out (cons 'release out))) 62 out)) 63 64 (define (encode-modifier in) 65 (let ((encode-mod-map '((shift . 1) (lock . 2) 66 (control . 4) (mod-1 . 8) 67 (mod-2 . 16) (mod-3 . 32) (mod-4 . 64) 68 (mod-5 . 128) (button-1 . 256) 69 (button-2 . 512) (button-3 . 1024) 70 (button-4 . 2048) (button-5 . 4096) 71 (meta . #x100000) (alt . #x200000) 72 (hyper . #x1000000) (super . #x2000000) 73 (wm . #x4000000) (any . #x400000) 74 (release . #x800000)))) 75 76 (apply + (mapcar (lambda (m) 77 (cdr (assq m encode-mod-map))) in)))) 78 79 (define (substitute-wm-modifier event) 80 (if (/= (logand (cdr event) #x04000000) 0) 81 (cons (car event) (logior (wm-modifier) (logand (cdr event) 82 (lognot #x04000000)))) 83 event)) 84 85 (define (decode-event event) 86 "Return a symbol description of the low-level event structure 87EVENT (a cons cell). The symbolic description has the form `(TYPE 88MODIFIER-LIST ACTION)'." 89 (let* ((code (car event)) 90 (mods (cdr event))) 91 92 (cond ((not (zerop (logand mods (lsh 1 16)))) 93 ;; keyboard event 94 (list 'key (decode-modifier mods) (x-keysym-name code))) 95 ((not (zerop (logand mods (lsh 1 17)))) 96 ;; mouse event 97 (list 'mouse (decode-modifier mods) 98 (aref [click-1 click-2 move off-1 click-3 off-2 off-3] 99 (1- code)))) 100 (t (error "Unknown event type"))))) 101 102 (define (encode-event event) 103 "Return the low-level event structure (cons cell) representing the 104symbolic event description EVENT, a list `(TYPE MODIFIER-LIST 105ACTION)'." 106 (let* ((code 0) 107 (mods (encode-modifier (cadr event)))) 108 109 (cond ((eq (car event) 'key) 110 (setq mods (logior mods (lsh 1 16))) 111 (setq code (x-lookup-keysym (caddr event)))) 112 ((eq (car event) 'mouse) 113 (setq mods (logior mods (lsh 1 17))) 114 (setq code (cdr (assq (caddr event) '((click . 1) 115 (click-1 . 1) 116 (click-2 . 2) 117 (move . 3) 118 (off . 4) 119 (off-1 . 4) 120 (click-3 . 5) 121 (off-2 . 6) 122 (off-3 . 7)))))) 123 (t (error "Unknown event type: %s" (car event)))) 124 (cons code mods))) 125 126 (define (string->keysym string) 127 "Convert a string naming a key into a symbol naming an X11 keysym." 128 (x-keysym-name (car (lookup-event string)))) 129 130 (define (modifier->keysyms modifier) 131 "Convert a symbol naming an event modifier into a list of symbols 132representing the X11 keysyms that may generate the modifier." 133 (cond ((eq modifier 'alt) 134 (mapcar string->keysym alt-keysyms)) 135 ((eq modifier 'meta) 136 (mapcar string->keysym meta-keysyms)) 137 ((eq modifier 'hyper) 138 (mapcar string->keysym hyper-keysyms)) 139 ((eq modifier 'super) 140 (mapcar string->keysym super-keysyms)) 141 ((eq modifier 'shift) 142 '(Shift_L Shift_R)) 143 ((eq modifier 'control) 144 '(Control_L Control_R)) 145 (t (error "Unknown modifier: %s" modifier)))) 146 147 (define (modifier-keysym-p keysym) 148 "Returns true if KEYSYM is a modifier keysym." 149 (or (memq keysym '(Shift_L Shift_R Control_L Control_R)) 150 (member (symbol-name keysym) alt-keysyms) 151 (member (symbol-name keysym) meta-keysyms) 152 (member (symbol-name keysym) hyper-keysyms) 153 (member (symbol-name keysym) super-keysyms))) 154 155 (define (member-event ev lst) 156 (let loop ((rest lst)) 157 (cond ((null rest) nil) 158 ((event-match ev (car rest)) rest) 159 (t (loop (cdr rest)))))) 160 161 (define (should-grab-button-event-p event keymap) 162 (let* ((decoded (decode-event event)) 163 (variants (mapcar (lambda (action) 164 (encode-event 165 (list (car decoded) (cadr decoded) action))) 166 '(click-2 click-3 move off-1 off-2 off-3)))) 167 (let loop ((rest (cdr keymap))) 168 (cond ((null rest) nil) 169 ((member-event (cdar rest) variants) t) 170 (t (loop (cdr rest)))))))) 171