-;; Emulate the Lucid event data type and associated functions.
-;; Copyright (C) 1993 Free Software Foundation, Inc.
+;;; levents.el --- emulate the Lucid event data type and associated functions
+
+;; Copyright (C) 1993, 2001 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: emulations
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
-;;; Notes:
+;;; Commentary:
;; Things we cannot emulate in Lisp:
;; It is not possible to emulate current-mouse-event as a variable,
;;; Code:
+(defun next-command-event (event)
+ (error "You must rewrite to use `read-command-event' instead of `next-command-event'"))
+
+(defun next-event (event)
+ (error "You must rewrite to use `read-event' instead of `next-event'"))
+
+(defun dispatch-event (event)
+ (error "`dispatch-event' not supported"))
+
;; Make events of type eval, menu and timeout
;; execute properly.
(put 'menu 'event-symbol-elements '(eval))
(put 'timeout 'event-symbol-elements '(eval))
-(defsubst eventp (obj)
- "True if the argument is an event object."
- (or (integerp obj)
- (and (symbolp obj)
- (get obj 'event-symbol-elements))
- (and (consp obj)
- (symbolp (car obj))
- (get (car obj) 'event-symbol-elements))))
-
(defun allocate-event ()
"Returns an empty event structure.
In this emulation, it returns nil."
(or (memq 'click (get (car obj) 'event-symbol-elements))
(memq 'drag (get (car obj) 'event-symbol-elements)))))
+(defun button-event-p (obj)
+ "True if the argument is a mouse-button press or release event object."
+ (and (consp obj) (symbolp (car obj))
+ (or (memq 'click (get (car obj) 'event-symbol-elements))
+ (memq 'down (get (car obj) 'event-symbol-elements))
+ (memq 'drag (get (car obj) 'event-symbol-elements)))))
+
+(defun mouse-event-p (obj)
+ "True if the argument is a mouse-button press or release event object."
+ (and (consp obj) (symbolp (car obj))
+ (or (eq (car obj) 'mouse-movement)
+ (memq 'click (get (car obj) 'event-symbol-elements))
+ (memq 'down (get (car obj) 'event-symbol-elements))
+ (memq 'drag (get (car obj) 'event-symbol-elements)))))
+
(defun character-to-event (ch &optional event)
"Converts a numeric ASCII value to an event structure, replete with
bucky bits. The character is the first argument, and the event to fill
mean -- for example, the number 9 is converted to the character Tab,
not the distinct character Control-I.
-Beware that character-to-event and event-to-character are not strictly
-inverse functions, since events contain much more information than the
+Beware that character-to-event and event-to-character are not strictly
+inverse functions, since events contain much more information than the
ASCII character set can encode."
ch)
except via garbage collection and `cons'."
nil)
-(defun dispatch-event (event)
- "Given an event object returned by next-event, execute it."
- (let ((type (car-safe event)))
- (cond ((eq type 'eval)
- (funcall (nth 1 event) (nth 2 event)))
- ((eq type 'menu)
- (funcall (nth 1 event) (nth 2 event)))
- ((eq type 'switch-frame)
- (internal-select-frame (nth 1 event)))
- (t (error "keyboard and mouse events not allowed in `dispatch-event'")))))
-
(defun enqueue-eval-event: (function object)
"Add an eval event to the back of the queue.
It will be the next event read after all pending events."
(let ((base (logand event (1- (lsh 1 18)))))
(downcase (if (< base 32) (logior base 64) base)))))
-(defun event-modifiers (event)
- "Returns a list of symbols representing the modifier keys in event EVENT.
-The elements of the list may include `meta', `control',
-`shift', `hyper', `super', `alt'.
-See also the function `event-modifier-bits'."
- (let ((type event))
- (if (listp type)
- (setq type (car type)))
- (if (symbolp type)
- (cdr (get type 'event-symbol-elements))
- (let ((list nil))
- (or (zerop (logand type (lsh 1 23)))
- (setq list (cons 'meta list)))
- (or (and (zerop (logand type (lsh 1 22)))
- (>= (logand type 127) 32))
- (setq list (cons 'control list)))
- (or (and (zerop (logand type (lsh 1 21)))
- (= (logand type 255) (downcase (logand type 255))))
- (setq list (cons 'shift list)))
- (or (zerop (logand type (lsh 1 20)))
- (setq list (cons 'hyper list)))
- (or (zerop (logand type (lsh 1 19)))
- (setq list (cons 'super list)))
- (or (zerop (logand type (lsh 1 18)))
- (setq list (cons 'alt list)))
- list))))
-
-(defun event-modifier-bits (event)
- "Returns a number representing the modifier keys in event EVENT.
-See also the function `event-modifiers'."
- (let ((type event))
- (if (listp type)
- (setq type (car type)))
- (if (symbolp type)
- (logand (lsh 63 18)
- (nth 1 (get type 'event-symbol-element-mask)))
- (let ((bits (logand type (lsh 63 18)))
- (base (logand type 127)))
- ;; Put in Control and Shift bits
- ;; in the cases where the basic code expresses them.
- (if (< base 32)
- (setq bits (logior (lsh 1 22) bits)))
- (if (/= base (downcase base))
- (setq bits (logior (lsh 1 21) bits)))
- bits))))
-
(defun event-object (event)
"Returns the function argument of the given timeout, menu, or eval event."
(nth 2 event))
into the buffer visible in the event's window."
(posn-point (event-end event)))
+;; Return position of start of line LINE in WINDOW.
+;; If LINE is nil, return the last position
+;; visible in WINDOW.
+(defun event-closest-point-1 (window &optional line)
+ (let* ((total (- (window-height window)
+ (if (window-minibuffer-p window)
+ 0 1)))
+ (distance (or line total)))
+ (save-excursion
+ (goto-char (window-start window))
+ (if (= (vertical-motion distance) distance)
+ (if (not line)
+ (forward-char -1)))
+ (point))))
+
+(defun event-closest-point (event &optional start-window)
+ "Return the nearest position to where EVENT ended its motion.
+This is computed for the window where EVENT's motion started,
+or for window WINDOW if that is specified."
+ (or start-window (setq start-window (posn-window (event-start event))))
+ (if (eq start-window (posn-window (event-end event)))
+ (if (eq (event-point event) 'vertical-line)
+ (event-closest-point-1 start-window
+ (cdr (posn-col-row (event-end event))))
+ (if (eq (event-point event) 'mode-line)
+ (event-closest-point-1 start-window)
+ (event-point event)))
+ ;; EVENT ended in some other window.
+ (let* ((end-w (posn-window (event-end event)))
+ (end-w-top)
+ (w-top (nth 1 (window-edges start-window))))
+ (setq end-w-top
+ (if (windowp end-w)
+ (nth 1 (window-edges end-w))
+ (/ (cdr (posn-x-y (event-end event)))
+ (frame-char-height end-w))))
+ (if (>= end-w-top w-top)
+ (event-closest-point-1 start-window)
+ (window-start start-window)))))
+
(defun event-process (event)
"Returns the process of the given process-output event."
(nth 1 event))
(defun event-to-character (event &optional lenient)
"Returns the closest ASCII approximation to the given event object.
If the event isn't a keypress, this returns nil.
-If the second argument is non-nil, then this is lenient in its
+If the second argument is non-nil, then this is lenient in its
translation; it will ignore modifier keys other than control and meta,
-and will ignore the shift modifier on those characters which have no
-shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
-the same ASCII code as Control-A.) If the second arg is nil, then nil
+and will ignore the shift modifier on those characters which have no
+shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
+the same ASCII code as Control-A.) If the second arg is nil, then nil
will be returned for events which have no direct ASCII equivalent."
(if (symbolp event)
(and lenient
(defun event-x (event)
"Returns the X position in characters of the given mouse-related event."
(/ (car (posn-col-row (event-end event)))
- (character-width (window-frame (event-window event)))))
+ (frame-char-width (window-frame (event-window event)))))
(defun event-x-pixel (event)
"Returns the X position in pixels of the given mouse-related event."
(defun event-y (event)
"Returns the Y position in characters of the given mouse-related event."
(/ (cdr (posn-col-row (event-end event)))
- (character-width (window-frame (event-window event)))))
+ (frame-char-height (window-frame (event-window event)))))
(defun event-y-pixel (event)
"Returns the Y position in pixels of the given mouse-related event."
"True if the argument is a mouse-motion event object."
(eq (car-safe obj) 'mouse-movement))
-(defun next-command-event (event)
- "Given an event structure, fills it in with the next keyboard, mouse
-press, or mouse release event available from the user. If there are
-non-command events available (mouse motion, sub-process output, etc) then
-these will be executed (with dispatch-event) and discarded."
- (while (progn
- (next-event event)
- (not (or (key-press-event-p event)
- (button-press-event-p event)
- (button-release-event-p event)
- (menu-event-p event))))
- (dispatch-event event)))
-
-(defun next-event (event &optional ignore)
- "Given an event structure, fills it in with the next event available
-from the window system or terminal driver. Pass this object to
-`dispatch-event' to handle it.
-
-See also the function `next-command-event'.
-
-If the second optional argument is non-nil, then this will never return
-key-press and mouse-click events, but will delay them until later. You
-should probably never need to use this option; it is used for implementing
-the `wait-reading-process-input' function."
- (read-event))
+(defun read-command-event ()
+ "Return the next keyboard or mouse event; execute other events.
+This is similar to the function `next-command-event' of Lucid Emacs,
+but different in that it returns the event rather than filling in
+an existing event object."
+ (let (event)
+ (while (progn
+ (setq event (read-event))
+ (not (or (key-press-event-p event)
+ (button-press-event-p event)
+ (button-release-event-p event)
+ (menu-event-p event))))
+ (let ((type (car-safe event)))
+ (cond ((eq type 'eval)
+ (funcall (nth 1 event) (nth 2 event)))
+ ((eq type 'switch-frame)
+ (select-frame (nth 1 event))))))
+ event))
(defun process-event-p (obj)
"True if the argument is a process-output event object.
GNU Emacs 19 does not currently generate process-output events."
(eq (car-safe obj) 'process))
-(defun timeout-event-p (obj)
- "True if the argument is a timeout event object.
-GNU Emacs 19 does not currently generate timeout events."
- (eq (car-safe obj) 'timeout))
+(provide 'levents)
+;;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525
;;; levents.el ends here