X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ecc71b7f7d22cc90df74678375f54645c007f96b..95e4aa8ef26b42d70558543ecdd9eca8e095d57b:/lisp/emacs-lisp/levents.el diff --git a/lisp/emacs-lisp/levents.el b/lisp/emacs-lisp/levents.el index b2a91f8dc1..cd3fe2764c 100644 --- a/lisp/emacs-lisp/levents.el +++ b/lisp/emacs-lisp/levents.el @@ -1,5 +1,9 @@ -;; 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. @@ -14,10 +18,11 @@ ;; 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, @@ -31,6 +36,15 @@ ;;; 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. @@ -46,15 +60,6 @@ (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." @@ -71,6 +76,21 @@ 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 @@ -78,8 +98,8 @@ in is the second. This function contains knowledge about what the codes 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) @@ -100,17 +120,6 @@ This emulation does not actually deallocate or reuse events 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." @@ -140,52 +149,6 @@ The value is an ASCII printing character (not upper case) or a symbol." (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)) @@ -197,6 +160,46 @@ not occur over text, then this returns nil. Otherwise, it returns an index 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)) @@ -211,11 +214,11 @@ In this emulation, it returns nil for non-mouse-related events." (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 @@ -232,7 +235,7 @@ will be returned for events which have no direct ASCII equivalent." (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." @@ -241,7 +244,7 @@ will be returned for events which have no direct ASCII equivalent." (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." @@ -261,40 +264,31 @@ will be returned for events which have no direct ASCII equivalent." "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