X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/aae56ea7ca8c74e7bb5595b828851aaa9f947792..ca2ddd8ed551b1ffb4ecc0142add2c642b79adce:/lisp/emacs-lisp/levents.el diff --git a/lisp/emacs-lisp/levents.el b/lisp/emacs-lisp/levents.el index 1c67ba946f..0cb860c6d4 100644 --- a/lisp/emacs-lisp/levents.el +++ b/lisp/emacs-lisp/levents.el @@ -15,8 +15,9 @@ ;; 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. ;;; Commentary: @@ -56,15 +57,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." @@ -81,6 +73,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 @@ -139,52 +146,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)) @@ -196,6 +157,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)) @@ -276,7 +277,7 @@ an existing event object." (cond ((eq type 'eval) (funcall (nth 1 event) (nth 2 event))) ((eq type 'switch-frame) - (internal-select-frame (nth 1 event)))))) + (select-frame (nth 1 event)))))) event)) (defun process-event-p (obj) @@ -284,9 +285,6 @@ an existing 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) ;;; levents.el ends here