sun-mouse.el

windows版本的emacs

;;; sun-mouse.el --- mouse handling for Sun windows

;; Copyright (C) 1987 Free Software Foundation, Inc.

;; Author: Jeff Peck
;; Maintainer: FSF
;; Keywords: hardware

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; 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, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Jeff Peck, Sun Microsystems, Jan 1987.
;; Original idea by Stan Jefferson

;;     Modeled after the GNUEMACS keymap interface.
;;
;; User Functions:
;;   make-mousemap, copy-mousemap, 
;;   define-mouse, global-set-mouse, local-set-mouse,
;;   use-global-mousemap, use-local-mousemap,
;;   mouse-lookup, describe-mouse-bindings
;;
;; Options:
;;   extra-click-wait, scrollbar-width

;;; Code:

(defvar extra-click-wait 150
  "*Number of milliseconds to wait for an extra click.
Set this to zero if you don't want chords or double clicks.")

(defvar scrollbar-width 5
  "*The character width of the scrollbar.
The cursor is deemed to be in the right edge scrollbar if it is this near the
right edge, and more than two chars past the end of the indicated line.
Setting to nil limits the scrollbar to the edge or vertical dividing bar.")

;;;
;;; Mousemaps
;;;
(defun make-mousemap ()
  "Returns a new mousemap."
  (cons 'mousemap nil))

(defun copy-mousemap (mousemap)
  "Return a copy of mousemap."
  (copy-alist mousemap))

(defun define-mouse (mousemap mouse-list def)
  "Args MOUSEMAP, MOUSE-LIST, DEF.  Define MOUSE-LIST in MOUSEMAP as DEF.
MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules:
  * One of these atoms specifies the active region of the definition.
	text, scrollbar, modeline, minibuffer
  * One or two or these atoms specify the button or button combination.
        left, middle, right, double
  * Any combination of these atoms specify the active shift keys.
        control, shift, meta
  * With a single unshifted button, you can add
	up
    to indicate an up-click.
The atom `double' is used with a button designator to denote a double click.
Two button chords are denoted by listing the two buttons.
See sun-mouse-handler for the treatment of the form DEF."
  (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def))

(defun global-set-mouse (mouse-list def)
  "Give MOUSE-EVENT-LIST a local definition of DEF.
See define-mouse for a description of MOUSE-EVENT-LIST and DEF.
Note that if MOUSE-EVENT-LIST has a local definition in the current buffer,
that local definition will continue to shadow any global definition."
  (interactive "xMouse event: \nxDefinition: ")
  (define-mouse current-global-mousemap mouse-list def))

(defun local-set-mouse (mouse-list def)
  "Give MOUSE-EVENT-LIST a local definition of DEF.
See define-mouse for a description of the arguments.
The definition goes in the current buffer's local mousemap.
Normally buffers in the same major mode share a local mousemap."
  (interactive "xMouse event: \nxDefinition: ")
  (if (null current-local-mousemap)
      (setq current-local-mousemap (make-mousemap)))
  (define-mouse current-local-mousemap mouse-list def))

(defun use-global-mousemap (mousemap)
  "Selects MOUSEMAP as the global mousemap."
  (setq current-global-mousemap mousemap))

(defun use-local-mousemap (mousemap)
  "Selects MOUSEMAP as the local mousemap.
nil for MOUSEMAP means no local mousemap."
  (setq current-local-mousemap mousemap))


;;;
;;; Interface to the Mouse encoding defined in Emacstool.c
;;;
;;; Called when mouse-prefix is sent to emacs, additional
;;; information is read in as a list (button x y time-delta)
;;;
;;; First, some generally useful functions:
;;;

(defun logtest (x y)
  "True if any bits set in X are also set in Y.
Just like the Common Lisp function of the same name."
  (not (zerop (logand x y))))


;;;
;;; Hit accessors.
;;;

(defconst sm::ButtonBits 7)		; Lowest 3 bits.
(defconst sm::ShiftmaskBits 56)		; Second lowest 3 bits (56 = 63 - 7).
(defconst sm::DoubleBits 64)		; Bit 7.
(defconst sm::UpBits 128)		; Bit 8.

;;; All the useful code bits
(defmacro sm::hit-code (hit)
  (` (nth 0 (, hit))))
;;; The button, or buttons if a chord.
(defmacro sm::hit-button (hit)
  (` (logand sm::ButtonBits (nth 0 (, hit)))))
;;; The shift, control, and meta flags.
(defmacro sm::hit-shiftmask (hit)
  (` (logand sm::ShiftmaskBits (nth 0 (, hit)))))
;;; Set if a double click (but not a chord).
(defmacro sm::hit-double (hit)
  (` (logand sm::DoubleBits (nth 0 (, hit)))))
;;; Set on button release (as opposed to button press).
(defmacro sm::hit-up (hit)
  (` (logand sm::UpBits (nth 0 (, hit)))))
;;; Screen x position.
(defmacro sm::hit-x (hit) (list 'nth 1 hit))
;;; Screen y position.
(defmacro sm::hit-y (hit) (list 'nth 2 hit))
;;; Milliseconds since last hit.
(defmacro sm::hit-delta (hit) (list 'nth 3 hit))

(defmacro sm::hit-up-p (hit)		; A predicate.
  (` (not (zerop (sm::hit-up (, hit))))))

;;;
;;; Loc accessors.  for sm::window-xy
;;;
(defmacro sm::loc-w (loc) (list 'nth 0 loc))
(defmacro sm::loc-x (loc) (list 'nth 1 loc))
(defmacro sm::loc-y (loc) (list 'nth 2 loc))

(defmacro eval-in-buffer (buffer &rest forms)
  "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer."
  ;; When you don't need the complete window context of eval-in-window
  (` (let ((StartBuffer (current-buffer)))
    (unwind-protect
	(progn
	  (set-buffer (, buffer))
	  (,@ forms))
    (set-buffer StartBuffer)))))

(put 'eval-in-buffer 'lisp-indent-function 1)

;;; this is used extensively by sun-fns.el
;;;
(defmacro eval-in-window (window &rest forms)
  "Switch to WINDOW, evaluate FORMS, return to original window."
  (` (let ((OriginallySelectedWindow (selected-window)))
       (unwind-protect
	   (progn
	     (select-window (, window))
	     (,@ forms))
	 (select-window OriginallySelectedWindow)))))
(put 'eval-in-window 'lisp-indent-function 1)

;;;
;;; handy utility, generalizes window_loop
;;;

;;; It's a macro (and does not evaluate its arguments).
(defmacro eval-in-windows (form &optional yesmini)
  "Switches to each window and evaluates FORM.  Optional argument
YESMINI says to include the minibuffer as a window.
This is a macro, and does not evaluate its arguments."
  (` (let ((OriginallySelectedWindow (selected-window)))
       (unwind-protect 
	   (while (progn
		    (, form)
		    (not (eq OriginallySelectedWindow
			     (select-window
			      (next-window nil (, yesmini)))))))
	 (select-window OriginallySelectedWindow)))))
(put 'eval-in-window 'lisp-indent-function 0)

(defun move-to-loc (x y)
  "Move cursor to window location X, Y.
Handles wrapped and horizontally scrolled lines correctly."
  (move-to-window-line y)
  ;; window-line-end expects this to return the window column it moved to.
  (let ((cc (current-column))
	(nc (move-to-column
	     (if (zerop (window-hscroll))
		 (+ (current-column)
		    (min (- (window-width) 2)	; To stay on the line.
			 x))
	       (+ (window-hscroll) -1
		  (min (1- (window-width))	; To stay on the line.
		       x))))))
    (- nc cc)))


(defun minibuffer-window-p (window)
  "True iff this WINDOW is minibuffer."
  (= (frame-height)
     (nth 3 (window-edges window))	; The bottom edge.
     ))


(defun sun-mouse-handler (&optional hit)
  "Evaluates the function or list associated with a mouse hit.
Expecting to read a hit, which is a list: (button x y delta).  
A form bound to button by define-mouse is found by mouse-lookup. 
The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound.  
If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*,
*mouse-x*, and *mouse-y* as arguments; if the form is a list (listp),
the form is eval'ed; if the form is neither of these, it is an error.
Returns nil."
  (interactive)
  (if (null hit) (setq hit (sm::combined-hits)))
  (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit))))
    (let ((*mouse-window* (sm::loc-w loc))
	  (*mouse-x* (sm::loc-x loc))
	  (*mouse-y* (sm::loc-y loc))
	  (mouse-code (mouse-event-code hit loc)))
      (let ((form (eval-in-buffer (window-buffer *mouse-window*)
		    (mouse-lookup mouse-code))))
	(cond ((null form)
	       (if (not (sm::hit-up-p hit))	; undefined up hits are ok.
		   (error "Undefined mouse event: %s" 
			  (prin1-to-string 
			   (mouse-code-to-mouse-list mouse-code)))))
	      ((symbolp form)
	       (setq this-command form)
	       (funcall form *mouse-window* *mouse-x* *mouse-y*))
	      ((listp form)
	       (setq this-command (car form))
	       (eval form))
	      (t
	       (error "Mouse action must be symbol or list, but was: %s"
		      form))))))
  ;; Don't let 'sun-mouse-handler get on last-command,
  ;; since this function should be transparent.
  (if (eq this-command 'sun-mouse-handler)
      (setq this-command last-command))
  ;; (message (prin1-to-string this-command))	; to see what your buttons did
  nil)

(defun sm::combined-hits ()
  "Read and return next mouse-hit, include possible double click"
  (let ((hit1 (mouse-hit-read)))
    (if (not (sm::hit-up-p hit1))      ; Up hits don't start doubles or chords.
	(let ((hit2 (mouse-second-hit extra-click-wait)))
	  (if hit2	; we cons'd it, we can smash it.
	      ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...))
	      (setcar hit1 (logior (sm::hit-code hit1) 
				   (sm::hit-code hit2)
				   (if (= (sm::hit-button hit1) 
					  (sm::hit-button hit2))
				       sm::DoubleBits 0))))))
    hit1))

(defun mouse-hit-read ()
  "Read mouse-hit list from keyboard.  Like (read 'read-char),
but that uses minibuffer, and mucks up last-command."
  (let ((char-list nil) (char nil))
    (while (not (equal 13		; Carriage return.
		       (prog1 (setq char (read-char)) 
			 (setq char-list (cons char char-list))))))
    (read (mapconcat 'char-to-string (nreverse char-list) ""))
    ))

;;; Second Click Hackery....
;;; if prefix is not mouse-prefix, need a way to unread the char...
;;; or else have mouse flush input queue, or else need a peek at next char.

;;; There is no peek, but since one character can be unread, we only
;;; have to flush the queue when the command after a mouse click
;;; starts with mouse-prefix1 (see below).
;;;   Something to do later:  We could buffer the read commands and
;;; execute them ourselves after doing the mouse command (using
;;; lookup-key ??).

(defvar mouse-prefix1 24		; C-x
  "First char of mouse-prefix.  Used to detect double clicks and chords.")

(defvar mouse-prefix2 0			; C-@
  "Second char of mouse-prefix.  Used to detect double clicks and chords.")


(defun mouse-second-hit (hit-wait)
  "Returns the next mouse hit occurring within HIT-WAIT milliseconds."
  (if (sit-for-millisecs hit-wait) nil	; No input within hit-wait millisecs.
    (let ((pc1 (read-char)))
      (if (or (not (equal pc1 mouse-prefix1))
	      (sit-for-millisecs 3))	; a mouse prefix will have second char
	  ;; Can get away with one unread.
	  (progn (setq unread-command-events (list pc1))
		 nil)			; Next input not mouse event.
	(let ((pc2 (read-char)))
	  (if (not (equal pc2 mouse-prefix2))
	      (progn (setq unread-command-events (list pc1)) ; put back the ^X
;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2))
;;; Well, now we can, but I don't understand this code well enough to fix it...
		(ding)			; user will have to retype that pc2.
		nil)			; This input is not a mouse event.
	    ;; Next input has mouse prefix and is within time limit.
	    (let ((new-hit (mouse-hit-read))) ; Read the new hit.
		(if (sm::hit-up-p new-hit)	; Ignore up events when timing.
		    (mouse-second-hit (- hit-wait (sm::hit-delta new-hit)))
		  new-hit		; New down hit within limit, return it.
		  ))))))))

(defun sm::window-xy (x y)
  "Find window containing screen coordinates X and Y.
Returns list (window x y) where x and y are relative to window."
  (or
   (catch 'found
     (eval-in-windows