sun-fns.el

早期freebsd实现

;; Subroutines of Mouse handling for Sun windows
;; Copyright (C) 1987 Free Software Foundation, Inc.

;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Submitted Mar. 1987, Jeff Peck
;;;		 	 Sun Microsystems Inc. <[e-mail]>
;;; Conceived Nov. 1986, Stan Jefferson,
;;;                      Computer Science Lab, SRI International.
;;; GoodIdeas Feb. 1987, Steve Greenbaum
;;; & UpClicks           Reasoning Systems, Inc.
;;;
(provide 'sun-fns)
(require 'sun-mouse)
;;;
;;; Functions for manipulating via the mouse and mouse-map definitions
;;; for accessing them.  Also definitons of mouse menus.
;;; This file you should freely modify to reflect you personal tastes.
;;;
;;; First half of file defines functions to implement mouse commands,
;;; Don't delete any of those, just add what ever else you need.
;;; Second half of file defines mouse bindings, do whatever you want there.

;;;
;;;         Mouse Functions.
;;;
;;; These functions follow the sun-mouse-handler convention of being called
;;; with three arguements: (window x-pos y-pos)
;;; This makes it easy for a mouse executed command to know where the mouse is.
;;; Use the macro "eval-in-window" to execute a function 
;;; in a temporarily selected window.
;;;
;;; If you have a function that must be called with other arguments
;;; bind the mouse button to an s-exp that contains the necessary parameters.
;;; See "minibuffer" bindings for examples.
;;;
(defconst cursor-pause-milliseconds 300
  "*Number of milliseconds to display alternate cursor (usually the mark)")

(defun indicate-region (&optional pause)
  "Bounce cursor to mark for cursor-pause-milliseconds and back again"
  (or pause (setq pause cursor-pause-milliseconds))
  (let ((point (point)))
    (goto-char (mark))
    (sit-for-millisecs pause)
    ;(update-display)
    ;(sleep-for-millisecs pause)
    (goto-char point)))


;;;
;;; Text buffer operations
;;;
(defun mouse-move-point (window x y)
  "Move point to mouse cursor."
  (select-window window)
  (move-to-loc x y)
  (if (memq last-command	; support the mouse-copy/delete/yank
	    '(mouse-copy mouse-delete mouse-yank-move))
      (setq this-command 'mouse-yank-move))
  )

(defun mouse-set-mark (window x y)
  "Set mark at mouse cursor."
  (eval-in-window window	;; use this to get the unwind protect
    (let ((point (point)))
      (move-to-loc x y)
      (set-mark (point))
      (goto-char point)
      (indicate-region)))
  )

(defun mouse-set-mark-and-select (window x y)
  "Set mark at mouse cursor, and select that window."
  (select-window window)
  (mouse-set-mark window x y)
  )

(defun mouse-set-mark-and-stuff (w x y)
  "Set mark at mouse cursor, and put region in stuff buffer."
  (mouse-set-mark-and-select w x y)
  (sun-select-region (region-beginning) (region-end)))

;;;
;;; Simple mouse dragging stuff: marking with button up
;;;

(defvar *mouse-drag-window* nil)
(defvar *mouse-drag-x* -1)
(defvar *mouse-drag-y* -1)

(defun mouse-drag-move-point (window x y)
  "Move point to mouse cursor, and allow dragging."
  (mouse-move-point window x y)
  (setq *mouse-drag-window* window
	*mouse-drag-x* x
	*mouse-drag-y* y))

(defun mouse-drag-set-mark-stuff (window x y)
  "The up click handler that goes with mouse-drag-move-point.
If mouse is in same WINDOW but at different X or Y than when
mouse-drag-move-point was last executed, set the mark at mouse
and put the region in the stuff buffer."
  (if (and (eq *mouse-drag-window* window)
	   (not (and (equal *mouse-drag-x* x)
		     (equal *mouse-drag-y* y))))
      (mouse-set-mark-and-stuff window x y)
    (setq this-command last-command))	; this was just an upclick no-op.
  )

(defun mouse-select-or-drag-move-point (window x y)
  "Select window if not selected, otherwise do mouse-drag-move-point."
  (if (eq (selected-window) window)
      (mouse-drag-move-point window x y)
    (mouse-select-window window x y)))

;;;
;;; esoteria:
;;;
(defun mouse-exch-pt-and-mark (window x y)
  "Exchange point and mark."
  (select-window window)
  (exchange-point-and-mark)
  )

(defun mouse-call-kbd-macro (window x y)
  "Invokes last keyboard macro at mouse cursor."
  (mouse-move-point window x y)
  (call-last-kbd-macro)
  )

(defun mouse-mark-thing (window x y)
  "Set point and mark to text object using syntax table.
The resulting region is put in the sun-window stuff buffer.
Left or right Paren syntax marks an s-expression.  
Clicking at the end of a line marks the line including a trailing newline.  
If it doesn't recognize one of these it marks the character at point."
  (mouse-move-point window x y)
  (if (eobp) (open-line 1))
  (let* ((char (char-after (point)))
         (syntax (char-syntax char)))
    (cond
     ((eq syntax ?w)			; word.
      (forward-word 1)
      (set-mark (point))
      (forward-word -1))
     ;; try to include a single following whitespace (is this a good idea?)
     ;; No, not a good idea since inconsistent.
     ;;(if (eq (char-syntax (char-after (mark))) ?\ )
     ;;    (set-mark (1+ (mark))))
     ((eq syntax ?\( )			; open paren.
      (mark-sexp 1))
     ((eq syntax ?\) )			; close paren.
      (forward-char 1)
      (mark-sexp -1)
      (exchange-point-and-mark))
     ((eolp)				; mark line if at end.
      (set-mark (1+ (point)))
      (beginning-of-line 1))
     (t					; mark character
      (set-mark (1+ (point)))))
    (indicate-region))			; display region boundary.
  (sun-select-region (region-beginning) (region-end))
  )

(defun mouse-kill-thing (window x y)
  "Kill thing at mouse, and put point there."
  (mouse-mark-thing window x y)
  (kill-region-and-unmark (region-beginning) (region-end))
  )

(defun mouse-kill-thing-there (window x y)
  "Kill thing at mouse, leave point where it was.
See mouse-mark-thing for a description of the objects recognized."
  (eval-in-window window 
    (save-excursion
      (mouse-mark-thing window x y)
      (kill-region (region-beginning) (region-end))))
  )

(defun mouse-save-thing (window x y &optional quiet)
  "Put thing at mouse in kill ring.
See mouse-mark-thing for a description of the objects recognized."
  (mouse-mark-thing window x y)
  (copy-region-as-kill (region-beginning) (region-end))
  (if (not quiet) (message "Thing saved"))
  )

(defun mouse-save-thing-there (window x y &optional quiet)
  "Put thing at mouse in kill ring, leave point as is.
See mouse-mark-thing for a description of the objects recognized."
  (eval-in-window window
    (save-excursion
      (mouse-save-thing window x y quiet))))

;;;
;;; Mouse yanking...
;;;
(defun mouse-copy-thing (window x y)
  "Put thing at mouse in kill ring, yank to point.
See mouse-mark-thing for a description of the objects recognized."
  (setq last-command 'not-kill)	 ;Avoids appending to previous kills.
  (mouse-save-thing-there window x y t)
  (yank)
  (setq this-command 'yank))

(defun mouse-move-thing (window x y)
  "Kill thing at mouse, yank it to point.
See mouse-mark-thing for a description of the objects recognized."
  (setq last-command 'not-kill)	 ;Avoids appending to previous kills.
  (mouse-kill-thing-there window x y)
  (yank)
  (setq this-command 'yank))

(defun mouse-yank-at-point (&optional window x y)
  "Yank from kill-ring at point; then cycle thru kill ring."
  (if (eq last-command 'yank)
      (let ((before (< (point) (mark))))
	(delete-region (point) (mark))
	(rotate-yank-pointer 1)
	(insert (car kill-ring-yank-pointer))
	(if before (exchange-point-and-mark)))
    (yank))
  (setq this-command 'yank))

(defun mouse-yank-at-mouse (window x y)
  "Yank from kill-ring at mouse; then cycle thru kill ring."
  (mouse-move-point window x y)
  (mouse-yank-at-point window x y))

(defun mouse-save/delete/yank (&optional window x y)
  "Context sensitive save/delete/yank.
Consecutive clicks perform as follows:
    * first click saves region to kill ring,
    * second click kills region,
    * third click yanks from kill ring,
    * subsequent clicks cycle thru kill ring.
If mouse-move-point is performed after the first or second click,
the next click will do a yank, etc.  Except for a possible mouse-move-point,
this command is insensitive to mouse location."
  (cond
   ((memq last-command '(mouse-delete yank mouse-yank-move))	; third+ click
    (mouse-yank-at-point))
   ((eq last-command 'mouse-copy)	; second click
    (kill-region (region-beginning) (region-end))
    (setq this-command 'mouse-delete))
   (t					; first click
    (copy-region-as-kill (region-beginning) (region-end))
    (message "Region saved")
    (setq this-command 'mouse-copy))
   ))


(defun mouse-split-horizontally (window x y)
  "Splits the window horizontally at mouse cursor."
  (eval-in-window window (split-window-horizontally (1+ x))))

(defun mouse-split-vertically (window x y)
  "Split the window vertically at the mouse cursor."
  (eval-in-window window (split-window-vertically (1+ y))))

(defun mouse-select-window (window x y)
  "Selects the window, restoring point."
  (select-window window))

(defun mouse-delete-other-windows (window x y)
  "Deletes all windows except the one mouse is in."
  (delete-other-windows window))

(defun mouse-delete-window (window x y)
  "Deletes the window mouse is in."
  (delete-window window))

(defun mouse-undo (window x y)
  "Invokes undo in the window mouse is in."
  (eval-in-window window (undo)))

;;;
;;; Scroll operations
;;;

;;; The move-to-window-line is used below because otherwise
;;; scrolling a non-selected process window with the mouse, after
;;; the process has written text past the bottom of the window,
;;; gives an "End of buffer" error, and then scrolls.  The
;;; move-to-window-line seems to force recomputing where things are.
(defun mouse-scroll-up (window x y)
  "Scrolls the window upward."
  (eval-in-window window (move-to-window-line 1) (scroll-up nil)))

(defun mouse-scroll-down (window x y)
  "Scrolls the window downward."
  (eval-in-window window (scroll-down nil)))

(defun mouse-scroll-proportional (window x y)
  "Scrolls the window proportionally corresponding to window
relative X divided by window width."
  (eval-in-window window 
    (if (>= x (1- (window-width)))
	;; When x is maximun (equal to or 1 less than window width),
	;; goto end of buffer.  We check for this special case
	;; becuase the calculated goto-char often goes short of the