-;; Emulate the Lucid event data type and associated functions.
+;;; levents.el --- emulate the Lucid event data type and associated functions.
+
;; Copyright (C) 1993 Free Software Foundation, Inc.
;; 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,
(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
(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))
(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)
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