cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-events.el

   1 ;;; xwem-events.el --- Events handlers.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;;         Steve Youngs  <steve@youngs.au.com>
   7 ;; Created: 21 Mar 2003
   8 ;; Keywords: xlib, xwem
   9 ;; X-CVS: $Id: xwem-events.el,v 1.11 2005-04-04 19:54:11 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31 ;;
  32 ;; This file used to work with X events, also includes some events
  33 ;; handlers.
  34 ;;
  35 ;;; Code
  36 \f
  37 (require 'xwem-load)
  38
  39 ;;;###xwem-autoload
  40 (defun xwem-ev-reconfig (xdpy win xev)
  41   "Common ConfigureRequest handler."
  42   (let* ((win (X-Event-xconfigurerequest-window xev))
  43          (cl (xwem-xwin-cl win))
  44          (vmask (X-Event-xconfigurerequest-value-mask xev)))
  45
  46     (xwem-debug 'xwem-event
  47                 "XWEM-EVENTS: ConfigureRequest event for win=%s vmask=%s, x=%S, y=%S, width=%S, height=%S"
  48                 '(X-Win-id win) 'vmask '(X-Event-xconfigurerequest-x xev) '(X-Event-xconfigurerequest-y xev)
  49                 '(X-Event-xconfigurerequest-width xev) '(X-Event-xconfigurerequest-height xev))
  50
  51     (if (not (xwem-cl-p cl))
  52         (when (xwem-misc-xwin-valid-p win)
  53           ;; Not yet managed client
  54           (XConfigureWindow (xwem-dpy) win
  55                             (make-X-Conf
  56                              :dpy (X-Win-dpy win)
  57                              :x (and (Xtest vmask X-CWX)
  58                                      (X-Event-xconfigurerequest-x xev))
  59                              :y (and (Xtest vmask X-CWY)
  60                                      (X-Event-xconfigurerequest-y xev))
  61                              :width (and (Xtest vmask X-CWWidth)
  62                                          (X-Event-xconfigurerequest-width xev))
  63                              :height (and (Xtest vmask X-CWHeight)
  64                                           (X-Event-xconfigurerequest-height xev))
  65                              :border-width (and (Xtest vmask X-CWBorderWidth)
  66                                                 (X-Event-xconfigurerequest-border-width xev))
  67                              :sibling (and (Xtest vmask X-CWSibling)
  68                                            (X-Event-xconfigurerequest-sibling xev))
  69                              :stackmode (and (Xtest vmask X-CWStackMode)
  70                                              (X-Event-xconfigurerequest-stackmode xev)))))
  71
  72       ;; Client window already in air
  73       (if (not (Xtest vmask (Xmask-or X-CWX X-CWY X-CWWidth X-CWHeight X-CWBorderWidth)))
  74           (xwem-cl-send-config cl)
  75
  76         ;; Geometry change
  77         (setf (xwem-cl-new-xgeom cl)
  78               (make-X-Geom :x (and (Xtest vmask X-CWX) (X-Event-xconfigurerequest-x xev))
  79                            :y (and (Xtest vmask X-CWY) (X-Event-xconfigurerequest-y xev))
  80                            :width (and (Xtest vmask X-CWWidth) (X-Event-xconfigurerequest-width xev))
  81                            :height (and (Xtest vmask X-CWHeight) (X-Event-xconfigurerequest-height xev))
  82                            :border-width (and (Xtest vmask X-CWBorderWidth) (X-Event-xconfigurerequest-border-width xev))))
  83         (xwem-refit cl)))))
  84
  85 ;;;###xwem-autoload
  86 (defun xwem-ev-resize (xdpy win xev)
  87   "Handle ResizeRequest event."
  88   (let ((cl (xwem-xwin-cl (X-Event-xresizerequest-window xev))))
  89     (when (xwem-cl-p cl)
  90       (xwem-client-resize cl (X-Event-xresizerequest-width xev)
  91                           (X-Event-xresizerequest-height xev)))))
  92
  93 ;;;###xwem-autoload
  94 (defun xwem-ev-mapreq (xdpy win xev)
  95   "Handle MapRequest event."
  96   (let ((cl (xwem-xwin-cl (X-Event-xmaprequest-window xev))))
  97     (if (xwem-cl-p cl)
  98         ;; Transition from Withdrawn->Normal/Iconic state
  99         (xwem-cl-honour-init-state cl)
 100
 101       ;; Initial window manage
 102       (xwem-xwin-try-to-manage (X-Event-xmaprequest-window xev)))))
 103
 104 ;;;###xwem-autoload
 105 (defun xwem-ev-unmap (xdpy win xev)
 106   "Handle UnmapNotify event."
 107   ;; NOTE: Obsolete X clients which does not send synthetic
 108   ;; UnmapNotify event (as described in ICCCM 4.1.4) to transit to
 109   ;; withdraw state, are not supported.
 110   (let (cl)
 111     (when (and (X-Event-synth-p xev)
 112                (not (X-Event-xunmap-from-configure xev))
 113                (xwem-cl-p (setq cl (xwem-xwin-cl (X-Event-xunmap-window xev))))
 114                (eq (xwem-cl-state cl) 'active))
 115       (xwem-withdraw cl))))
 116
 117 ;;;###xwem-autoload
 118 (defun xwem-ev-destroy (xdpy win xev)
 119   "Handle Destroy event."
 120   (let ((cl (xwem-xwin-cl (X-Event-xdestroywindow-window xev))))
 121     (when (xwem-cl-p cl)
 122       (xwem-cl-destroy cl))))
 123
 124
 125 ;;;; -- Events, command events, stuff --
 126 ;;;###xwem-autoload
 127 (defun xwem-event-client (xev)
 128   "Return client where X event XEV occured."
 129   (let ((ecl (and (X-Event-p xev)
 130                   (X-Win-p (X-Event-win xev))
 131                   (xwem-xwin-cl (X-Event-win xev)))))
 132     (if (or (not (xwem-cl-alive-p ecl))
 133             (eq ecl (xwem-dummy-client)))
 134         (xwem-cl-selected)
 135       ecl)))
 136
 137 ;;;###xwem-autoload
 138 (defun xwem-next-event (&optional timeout evt-list)
 139   "Fetch next Emacs keyboard or mouse event, with corresponding X Event.
 140
 141 If EVT-LIST is given, stop when event of type that in EVT-LIST is
 142 occured.  Default value of EVT-LIST is `(list X-KeyPress X-ButtonPress
 143 X-ButtonRelease X-MotionNotify)'.
 144
 145 Return Emacs event.  To acces corresponding X Event use
 146 `(event-object ev)' form."
 147   (let ((timo (and timeout (add-timeout timeout nil 'xwem-timeout)))
 148         (nev (allocate-event))
 149         (obj nil))
 150
 151     (while (progn
 152              (next-event nev)
 153              (not (cond ((and (timeout-event-p nev)
 154                               (eq (event-object nev) 'xwem-timeout))
 155                          (setq timo nil) ; unset it
 156                          t)
 157
 158                         ((and (eval-event-p nev)
 159                               (X-Event-p (event-object nev))
 160                               (memq (X-Event-type (event-object nev))
 161                                     (or evt-list
 162                                         (list X-KeyPress X-ButtonPress
 163                                               X-ButtonRelease X-MotionNotify))))
 164                          ;; next-event can fetch only
 165                          ;; keypress/buttonpress/buttonrelease/motion
 166                          ;; events
 167                          (setq obj (event-object nev))))))
 168       (dispatch-event nev))
 169
 170     (when timo
 171       (disable-timeout timo))
 172     (deallocate-event nev)
 173     obj))
 174
 175 (defun xwem-xevent-emacs-event (xev)
 176   "Return Emacs event corresponding to X Event XEV."
 177   (X-Event-get-property xev 'emacs-event))
 178
 179 (defsetf xwem-xevent-emacs-event (xev) (eev)
 180   `(X-Event-put-property ,xev 'emacs-event ,eev))
 181
 182
 183 ;;;###xwem-autoload
 184 (defun xwem-event-as-command (e-ev &optional x-ev)
 185   "Interpret event E-EV as command event.
 186 Optional X-EV specifies corresponding X Event."
 187   ;; Remember some information about command invocation
 188   (setq xwem-last-xevent x-ev
 189         xwem-event-client (xwem-event-client x-ev)
 190         xwem-last-event e-ev
 191         xwem-this-command-keys (vconcat (and (not (xwem-kbd-global-map-current-p))
 192                                              xwem-this-command-keys)
 193                                         (vector e-ev))))
 194
 195
 196 ;;;###xwem-autoload
 197 (defun xwem-next-command-event (&optional prompt)
 198   "Return next command event.
 199 Actually return cons cell where car is Emacs event and cdr is X Event."
 200   (let (eev cev xev)
 201     ;; Normal
 202     (when prompt
 203       (xwem-message 'prompt prompt))
 204
 205     ;; Process while interesting event occur
 206     (while (and (setq eev (next-event))
 207                 (not (cond ((and (eval-event-p eev)
 208                                  (X-Event-p (setq xev (event-object eev)))
 209                                  (memq (X-Event-type xev)
 210                                        (list X-KeyPress X-ButtonPress
 211                                              X-ButtonRelease X-MotionNotify))
 212                                  (setq cev (car (xwem-xevents->emacs-events (list xev) t))))
 213                             (X-Event-put-property xev 'emacs-event cev)
 214                             'break)
 215
 216                            ((and (eval-event-p eev)
 217                                  (eventp (setq cev (event-object eev)))
 218                                  (eq (event-function eev) 'xwem-dispatch-command-event))
 219                             ;; Unread command event
 220                             (setq xev nil)
 221                             'break))))
 222       (dispatch-event eev))
 223
 224     (when prompt
 225       (xwem-clear-message))
 226
 227     (xwem-event-as-command cev xev)
 228     (cons cev xev)))
 229
 230 ;;;###xwem-autoload
 231 (defun xwem-dispatch-command-event (eev &optional xev)
 232   "Dispatch command Emacs event EEV."
 233   (let* ((vev (or (and (vectorp eev) eev) (vector eev)))
 234          (ecl (xwem-event-client xev))
 235          (bind (or (xwem-lookup-key ecl vev)
 236                    ;; Then check for quit key
 237                    (and (eventp vev)
 238                         (equal xwem-quit-key
 239                                (events-to-keys vev))
 240                         xwem-quit-command)
 241                    ;; Then accept even default bindings
 242                    (xwem-lookup-key ecl vev t))))
 243     ;; If some button press/release does not have binding - ignore it
 244     (unless (and (null bind) (button-event-p eev))
 245       (xwem-event-as-command eev xev)
 246       ;; In case EEV is set of events - adjust command keys
 247       (when (vectorp eev)
 248         (setq xwem-this-command-keys eev))
 249       (xwem-kbd-dispatch-binding bind))))
 250
 251 ;;;###xwem-autoload
 252 (defun xwem-dispatch-command-xevent (xev)
 253   "Dispatch command event XEV."
 254   ;; If we are grabbing keyboard now and modifier pressed do nothing.
 255   (unless (or (= (X-Event-type xev) X-KeyRelease)
 256               (and (= (X-Event-type xev) X-KeyPress)
 257                    (xwem-kbd-kcode-modifier-p (X-Event-xkey-keycode xev))))
 258     (setf (xwem-xevent-emacs-event xev)
 259           (car (xwem-xevents->emacs-events (list xev) t)))
 260     (xwem-dispatch-command-event
 261      (xwem-xevent-emacs-event xev) xev)))
 262
 263 ;;; Unread command events support
 264 ;;;###xwem-autoload
 265 (defun xwem-unread-command-event (eev-or-xev)
 266   "Make event EV to be readed by `xwem-next-command-event' later,
 267 or to be executed by `xwem-dispatch-command-event'.
 268 Event EV can be either Emacs event, or X-Event."
 269   (enqueue-eval-event (if (X-Event-p eev-or-xev)
 270                           'xwem-dispatch-command-xevent
 271                         'xwem-dispatch-command-event)
 272                       eev-or-xev))
 273
 274 \f
 275 (provide 'xwem-events)
 276
 277 ;;; xwem-events.el ends here