git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/mode-motion.el

   1 ;;; mode-motion.el --- Mode-specific mouse-highlighting of text.
   2
   3 ;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: XEmacs Development Team
   6 ;; Keywords: internal, mouse, dumped
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF.
  26
  27 ;;; Commentary:
  28
  29 ;; This file is dumped with XEmacs (when window system support is compiled in).
  30
  31 ;;; Code:
  32
  33 (defvar mode-motion-hook nil
  34   "Function or functions which are called whenever the mouse moves.
  35 Each function must take a single argument of the motion event.
  36 You should normally use this rather than `mouse-motion-handler', which
  37 does some additional window-system-dependent things.  This hook is local
  38 to every buffer, and should normally be set up by major-modes which want
  39 to use special highlighting.  Every time the mouse moves over a window,
  40 the mode-motion-hook of the buffer of that window is run.")
  41
  42 (make-variable-buffer-local 'mode-motion-hook)
  43
  44 (defvar mode-motion-extent nil)
  45 (make-variable-buffer-local 'mode-motion-extent)
  46
  47 (defvar mode-motion-help-echo-string nil
  48   "String to be added as the 'help-echo property of the mode-motion extent.
  49 In order for this to work, you need to add the hook function
  50 `mode-motion-add-help-echo' to the mode-motion hook.  If this is a function,
  51 it will be called with one argument (the event) and should return a string
  52 to be added.  This variable is local to every buffer.")
  53 (make-variable-buffer-local 'mode-motion-help-echo-string)
  54
  55 (defun mode-motion-ensure-extent-ok (event)
  56   (let ((buffer (event-buffer event)))
  57     (if (and (extent-live-p mode-motion-extent)
  58              (eq buffer (extent-object mode-motion-extent)))
  59         nil
  60       (setq mode-motion-extent (make-extent nil nil buffer))
  61       (set-extent-property mode-motion-extent 'mouse-face 'highlight))))
  62
  63 (defun mode-motion-highlight-internal (event backward forward)
  64   (let* ((buffer (event-buffer event))
  65          (point (and buffer (event-point event))))
  66     (if (and buffer
  67              (not (eq buffer mouse-grabbed-buffer)))
  68         ;; #### ack!! Too many calls to save-window-excursion /
  69         ;; save-excursion (x-track-pointer calls, so does
  70         ;; minibuf-mouse-tracker ...) This needs to be looked
  71         ;; into.  It's complicated by the fact that sometimes
  72         ;; a mode-motion-hook might really want to change
  73         ;; the point.
  74         ;;
  75         ;; #### The save-excursion must come before the
  76         ;; save-window-excursion in order to function properly.  I
  77         ;; haven't given this much thought.  Is it a bug that this
  78         ;; ordering is necessary or is it correct behavior?
  79         (save-excursion
  80           (save-window-excursion
  81             (set-buffer buffer)
  82             (mode-motion-ensure-extent-ok event)
  83             (if point
  84                 ;; Use save-excursion here to avoid
  85                 ;; save-window-excursion seeing a change in
  86                 ;; window point's value which would make the
  87                 ;; display code do a whole lot of useless work
  88                 ;; and making the display flicker horribly.
  89                 (save-excursion
  90                   (goto-char point)
  91                   (condition-case nil (funcall backward) (error nil))
  92                   (setq point (point))
  93                   (condition-case nil (funcall forward) (error nil))
  94                   (if (eq point (point))
  95                       (detach-extent mode-motion-extent)
  96                     (set-extent-endpoints mode-motion-extent point (point))))
  97               ;; not over text; zero the extent.
  98               (detach-extent mode-motion-extent)))))))
  99
 100 (defun mode-motion-highlight-line (event)
 101   "For use as the value of `mode-motion-hook' -- highlight line under mouse."
 102   (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line))
 103
 104 (defun mode-motion-highlight-word (event)
 105   "For use as the value of `mode-motion-hook' -- highlight word under mouse."
 106   (mode-motion-highlight-internal
 107    event
 108    #'(lambda () (default-mouse-track-beginning-of-word nil))
 109    #'(lambda () (default-mouse-track-end-of-word nil))))
 110
 111 (defun mode-motion-highlight-symbol (event)
 112   "For use as the value of `mode-motion-hook' -- highlight symbol under mouse."
 113   (mode-motion-highlight-internal
 114    event
 115    #'(lambda () (default-mouse-track-beginning-of-word t))
 116    #'(lambda () (default-mouse-track-end-of-word t))))
 117
 118 (defun mode-motion-highlight-sexp (event)
 119   "For use as the value of `mode-motion-hook' -- highlight form under mouse."
 120   (mode-motion-highlight-internal
 121    event
 122    #'(lambda ()
 123        (if (= (char-syntax (following-char)) ?\()
 124            nil
 125          (goto-char (scan-sexps (point) -1))))
 126    #'(lambda ()
 127        (if (= (char-syntax (following-char)) ?\))
 128            (forward-char 1))
 129        (goto-char (scan-sexps (point) 1)))))
 130
 131 (defun mode-motion-add-help-echo (event)
 132   "For use as the value of `mode-motion-hook' -- add a 'help-echo property.
 133 This causes the string in the 'help-echo property to be displayed when the
 134 mouse moves over the extent.  See `mode-motion-help-echo-string' for
 135 documentation on how to control the string that is added."
 136   (mode-motion-ensure-extent-ok event)
 137   (let ((string (cond ((null mode-motion-help-echo-string) nil)
 138                       ((stringp mode-motion-help-echo-string)
 139                        mode-motion-help-echo-string)
 140                       (t (funcall mode-motion-help-echo-string event)))))
 141     (if (stringp string)
 142         (set-extent-property mode-motion-extent 'help-echo string))))
 143
 144 \f
 145 (provide 'mode-motion)
 146
 147 ;;; mode-motion.el ends here