sun-mouse.el

早期freebsd实现

	      (te (nth 1 we))
	      (re (nth 2 we))
	      (be (nth 3 we)))
	  (if (= re (screen-width))
	      ;; include the continuation column with this window
	      (setq re (1+ re)))
	  (if (= be (screen-height))
	      ;; include partial line at bottom of screen with this window
	      ;; id est, if window is not multple of char size.
	      (setq be (1+ be)))

	  (if (and (>= x le) (< x re)
		   (>= y te) (< y be))
	      (throw 'found 
		     (list (selected-window) (- x le) (- y te))))))
      t))				; include minibuffer in eval-in-windows
   ;;If x,y from a real mouse click, we shouldn't get here.
   (list nil x y)
   ))

(defun sm::window-region (loc)
  "Parse LOC into a region symbol.
Returns one of (text scrollbar modeline minibuffer)"
  (let ((w (sm::loc-w loc))
	(x (sm::loc-x loc))
	(y (sm::loc-y loc)))
    (let ((right (1- (window-width w)))
	  (bottom (1- (window-height w))))
      (cond ((minibuffer-window-p w) 'minibuffer)
	    ((>= y bottom) 'modeline)
	    ((>= x right) 'scrollbar)
	    ;; far right column (window seperator) is always a scrollbar
	    ((and scrollbar-width
		  ;; mouse within scrollbar-width of edge.
		  (>= x (- right scrollbar-width))
		  ;; mouse a few chars past the end of line.
		  (>= x (+ 2 (window-line-end w x y))))
	     'scrollbar)
	    (t 'text)))))

(defun window-line-end (w x y)
  "Return WINDOW column (ignore X) containing end of line Y"
  (eval-in-window w (save-excursion (move-to-loc (screen-width) y))))

;;;
;;; The encoding of mouse events into a mousemap.
;;; These values must agree with coding in emacstool:
;;;
(defconst sm::keyword-alist 
  '((left . 1) (middle . 2) (right . 4)
    (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128)
    (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048)
    ))

(defun mouse-event-code (hit loc)
  "Maps MOUSE-HIT and LOC into a mouse-code."
;;;Region is a code for one of text, modeline, scrollbar, or minibuffer.
  (logior (sm::hit-code hit)
	  (mouse-region-to-code (sm::window-region loc))))

(defun mouse-region-to-code (region)
  "Returns partial mouse-code for specified REGION."
  (cdr (assq region sm::keyword-alist)))

(defun mouse-list-to-mouse-code (mouse-list)
  "Map a MOUSE-LIST to a mouse-code."
  (apply 'logior
	 (mapcar (function (lambda (x)
			     (cdr (assq x sm::keyword-alist))))
		  mouse-list)))

(defun mouse-code-to-mouse-list (mouse-code)
  "Map a MOUSE-CODE to a mouse-list."
  (apply 'nconc (mapcar
		 (function (lambda (x)
			     (if (logtest mouse-code (cdr x))
				 (list (car x)))))
		 sm::keyword-alist)))

(defun mousemap-set (code mousemap value)
  (let* ((alist (cdr mousemap))
	 (assq-result (assq code alist)))
    (if assq-result
	(setcdr assq-result value)
      (setcdr mousemap (cons (cons code value) alist)))))

(defun mousemap-get (code mousemap)
  (cdr (assq code (cdr mousemap))))

(defun mouse-lookup (mouse-code)
  "Look up MOUSE-EVENT and return the definition. nil means undefined."
  (or (mousemap-get mouse-code current-local-mousemap)
      (mousemap-get mouse-code current-global-mousemap)))

;;;
;;; I (jpeck) don't understand the utility of the next four functions
;;; ask Steven Greenbaum <froud@kestrel>
;;;
(defun mouse-mask-lookup (mask list)
  "Args MASK (a bit mask) and LIST (a list of (code . form) pairs).
Returns a list of elements of LIST whose code or'ed with MASK is non-zero."
  (let ((result nil))
    (while list
      (if (logtest mask (car (car list)))
	  (setq result (cons (car list) result)))
      (setq list (cdr list)))
    result))

(defun mouse-union (l l-unique)
  "Return the union of list of mouse (code . form) pairs L and L-UNIQUE,
where L-UNIQUE is considered to be union'ized already."
  (let ((result l-unique))
    (while l
      (let ((code-form-pair (car l)))
	(if (not (assq (car code-form-pair) result))
	    (setq result (cons code-form-pair result))))
      (setq l (cdr l)))
    result))

(defun mouse-union-first-prefered (l1 l2)
  "Return the union of lists of mouse (code . form) pairs L1 and L2,
based on the code's, with preference going to elements in L1."
  (mouse-union l2 (mouse-union l1 nil)))

(defun mouse-code-function-pairs-of-region (region)
  "Return a list of (code . function) pairs, where each code is
currently set in the REGION."
  (let ((mask (mouse-region-to-code region)))
    (mouse-union-first-prefered
     (mouse-mask-lookup mask (cdr current-local-mousemap))
     (mouse-mask-lookup mask (cdr current-global-mousemap))
     )))

;;;
;;; Functions for DESCRIBE-MOUSE-BINDINGS
;;; And other mouse documentation functions
;;; Still need a good procedure to print out a help sheet in readable format.
;;;

(defun one-line-doc-string (function)
  "Returns first line of documentation string for FUNCTION.
If there is no documentation string, then the string
\"No documentation\" is returned."
  (while (consp function) (setq function (car function)))
  (let ((doc (documentation function)))
    (if (null doc)
	"No documentation."
      (string-match "^.*$" doc)
      (substring doc 0 (match-end 0)))))

(defun print-mouse-format (binding)
  (princ (car binding))
  (princ ": ")
  (mapcar (function
	   (lambda (mouse-list)
	     (princ mouse-list)
	     (princ " ")))
	  (cdr binding))
  (terpri)
  (princ "  ")
  (princ (one-line-doc-string (car binding)))
  (terpri)
  )

(defun print-mouse-bindings (region)
  "Prints mouse-event bindings for REGION."
  (mapcar 'print-mouse-format (sm::event-bindings region)))

(defun sm::event-bindings (region)
  "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION,
where each mouse-list is bound to the function in REGION."
  (let ((mouse-bindings (mouse-code-function-pairs-of-region region))
	(result nil))
    (while mouse-bindings
      (let* ((code-function-pair (car mouse-bindings))
	     (current-entry (assoc (cdr code-function-pair) result)))
	(if current-entry
	    (setcdr current-entry
		    (cons (mouse-code-to-mouse-list (car code-function-pair))
			  (cdr current-entry)))
	  (setq result (cons (cons (cdr code-function-pair)
				   (list (mouse-code-to-mouse-list
					  (car code-function-pair))))
			     result))))
      (setq mouse-bindings (cdr mouse-bindings))
      )
    result))

(defun describe-mouse-bindings ()
  "Lists all current mouse-event bindings."
  (interactive)
  (with-output-to-temp-buffer "*Help*"
    (princ "Text Region") (terpri)
    (princ "---- ------") (terpri)
    (print-mouse-bindings 'text) (terpri)
    (princ "Modeline Region") (terpri)
    (princ "-------- ------") (terpri)
    (print-mouse-bindings 'modeline) (terpri)
    (princ "Scrollbar Region") (terpri)
    (princ "--------- ------") (terpri)
    (print-mouse-bindings 'scrollbar)))

(defun describe-mouse-briefly (mouse-list)
  "Print a short description of the function bound to MOUSE-LIST."
  (interactive "xDescibe mouse list briefly: ")
  (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list))))
    (if function
	(message "%s runs the command %s" mouse-list function)
      (message "%s is undefined" mouse-list))))

(defun mouse-help-menu (function-and-binding)
  (cons (prin1-to-string (car function-and-binding))
	(menu-create	; Two sub-menu items of form ("String" . nil)
	 (list (list (one-line-doc-string (car function-and-binding)))
	       (list (prin1-to-string (cdr function-and-binding)))))))

(defun mouse-help-region (w x y &optional region)
  "Displays a menu of mouse functions callable in this region."
  (let* ((region (or region (sm::window-region (list w x y))))
	 (mlist (mapcar (function mouse-help-menu)
			(sm::event-bindings region)))
	 (menu (menu-create (cons (list (symbol-name region)) mlist)))
	 (item (sun-menu-evaluate w 0 y menu))
	 )))

;;;
;;; Menu interface functions
;;;
;;; use defmenu, because this interface is subject to change
;;; really need a menu-p, but we use vectorp and the context...
;;;
(defun menu-create (items)
  "Functional form for defmenu, given a list of ITEMS returns a menu.
Each ITEM is a (STRING . VALUE) pair."
  (apply 'vector items)
  )

(defmacro defmenu (menu &rest itemlist)
  "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs.
See sun-menu-evaluate for interpretation of ITEMS."
  (list 'defconst menu (funcall 'menu-create itemlist))
  )

(defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu)
  "Display a pop-up menu in WINDOW at X Y and evaluate selected item
of MENU.  MENU (or its symbol-value) should be a menu defined by defmenu.
  A menu ITEM is a (STRING . FORM) pair;
the FORM associated with the selected STRING is evaluated,
and the resulting value is returned.  Generally these FORMs are
evaluated for their side-effects rather than their values.
  If the selected form is a menu or a symbol whose value is a menu, 
then it is displayed and evaluated as a pullright menu item.
  If the the FORM of the first ITEM is nil, the STRING of the item
is used as a label for the menu, i.e. it's inverted and not selectible."

  (if (symbolp menu) (setq menu (symbol-value menu)))
  (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu)))

(defun sun-get-frame-data (code)
  "Sends the tty-sub-window escape sequence CODE to terminal,
and returns a cons of the two numbers in returned escape sequence.
That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". 
CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars."
  (send-string-to-terminal (concat "\033[" (int-to-string code) "t"))
  (let (char str x y)
    (while (not (equal 116 (setq char (read-char)))) ; #\t = 116
      (setq str (cons char str)))
    (setq str (mapconcat 'char-to-string (nreverse str) ""))
    (string-match ";[0-9]*" str)
    (setq y (substring str (1+ (match-beginning 0)) (match-end 0)))
    (setq str (substring str (match-end 0)))
    (string-match ";[0-9]*" str)
    (setq x (substring str (1+ (match-beginning 0)) (match-end 0)))
    (cons (string-to-int y) (string-to-int x))))

(defun sm::font-size ()
  "Returns font size in pixels: (cons Ysize Xsize)"
  (let ((pix (sun-get-frame-data 14))	; returns size in pixels
	(chr (sun-get-frame-data 18)))	; returns size in chars
    (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr)))))

(defvar sm::menu-kludge-x nil 
  "Cached frame-to-window X-Offset for sm::menu-kludge")
(defvar sm::menu-kludge-y nil 
  "Cached frame-to-window Y-Offset for sm::menu-kludge")

(defun sm::menu-kludge ()
  "If sunfns.c uses <Menu_Base_Kludge> this function must be here!"
  (or sm::menu-kludge-y
      (let ((fs (sm::font-size)))
	(setq sm::menu-kludge-y (+ 8 (car fs))	; a title line and borders
	      sm::menu-kludge-x 4)))	; best values depend on .defaults/Menu
  (let ((wl (sun-get-frame-data 13)))		; returns frame location
    (cons (+ (car wl) sm::menu-kludge-y)
	  (+ (cdr wl) sm::menu-kludge-x))))

;;;
;;;  Function interface to selection/region
;;;  primative functions are defined in sunfns.c
;;;
(defun sun-yank-selection ()
  "Set mark and yank the contents of the current sunwindows selection
into the current buffer at point."
  (interactive "*")
  (set-mark-command nil)
  (insert-string (sun-get-selection)))

(defun sun-select-region (beg end)
  "Set the sunwindows selection to the region in the current buffer."
  (interactive "r")
  (sun-set-selection (buffer-substring beg end)))

;;;
;;; Support for emacstool
;;; This closes the window instead of stopping emacs.
;;;
(defun suspend-emacstool (&optional stuffstring)
  "If running under as a detached process emacstool,
you don't want to suspend  (there is no way to resume), 
just close the window, and wait for reopening."
  (interactive)
  (if (and (boundp 'suspend-hook) suspend-hook)
      (funcall suspend-hook))
  (if stuffstring (send-string-to-terminal stuffstring))
  (send-string-to-terminal "\033[2t")	; To close EmacsTool window.
  (if (and (boundp 'suspend-resume-hook) suspend-resume-hook)
      (funcall suspend-resume-hook)))
;;;
;;; initialize mouse maps
;;;

(make-variable-buffer-local 'current-local-mousemap)
(setq-default current-local-mousemap nil)
(defvar current-global-mousemap (make-mousemap))