home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / mode-motion.el < prev    next >
Encoding:
Text File  |  1995-08-22  |  10.7 KB  |  270 lines
  1. ;; Mode-specific mouse-highlighting of text.
  2. ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  18. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar mode-motion-hook nil
  21.   "Function or functions which are called whenever the mouse moves.
  22. You should normally use this rather than `mouse-motion-handler', which 
  23. does some additional window-system-dependent things.  This hook is local
  24. to every buffer, and should normally be set up by major-modes which want
  25. to use special highlighting.  Every time the mouse moves over a window,
  26. the mode-motion-hook of the buffer of that window is run.")
  27.  
  28. (make-variable-buffer-local 'mode-motion-hook)
  29.  
  30. (defvar mode-motion-extent nil)
  31. (make-variable-buffer-local 'mode-motion-extent)
  32.  
  33. (defvar mode-motion-help-echo-string nil
  34.   "String to be added as the 'help-echo property of the mode-motion extent.
  35. In order for this to work, you need to add the hook function
  36. `mode-motion-add-help-echo' to the mode-motion hook.  If this is a function,
  37. it will be called with one argument (the event) and should return a string
  38. to be added.  This variable is local to every buffer.")
  39. (make-variable-buffer-local 'mode-motion-help-echo-string)
  40.  
  41. (defun mode-motion-ensure-extent-ok (event)
  42.   (let ((buffer (event-buffer event)))
  43.     (if (and (extent-live-p mode-motion-extent)
  44.          (eq buffer (extent-buffer mode-motion-extent)))
  45.     nil
  46.       (setq mode-motion-extent (make-extent nil nil buffer))
  47.       (set-extent-property mode-motion-extent 'highlight t))))
  48.  
  49. (defun mode-motion-highlight-internal (event backward forward)
  50.   (let* ((buffer (event-buffer event))
  51.      (point (and buffer (event-point event))))
  52.     (if (and buffer
  53.          (not (eq buffer mouse-grabbed-buffer)))
  54.     ;; #### ack!! Too many calls to save-window-excursion /
  55.     ;; save-excursion (x-track-pointer calls, so does
  56.     ;; minibuf-mouse-tracker ...) This needs to be looked
  57.     ;; into.  It's complicated by the fact that sometimes
  58.     ;; a mode-motion-hook might really want to change
  59.     ;; the point.
  60.     ;;
  61.     ;; #### The save-excursion must come before the
  62.     ;; save-window-excursion in order to function properly.  I
  63.     ;; haven't given this much thought.  Is it a bug that this
  64.     ;; ordering is necessary or is it correct behavior?
  65.     (save-excursion
  66.       (save-window-excursion
  67.         (set-buffer buffer)
  68.         (mode-motion-ensure-extent-ok event)
  69.         (if point
  70.         (progn
  71.           (goto-char point)
  72.           (condition-case nil (funcall backward) (error nil))
  73.           (setq point (point))
  74.           (condition-case nil (funcall forward) (error nil))
  75.           (if (eq point (point))
  76.               (detach-extent mode-motion-extent)
  77.             (set-extent-endpoints mode-motion-extent point (point))))
  78.           ;; not over text; zero the extent.
  79.           (detach-extent mode-motion-extent)))))))
  80.  
  81. (defun mode-motion-highlight-line (event)
  82.   "For use as the value of `mode-motion-hook' -- highlight line under mouse."
  83.   (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line))
  84.  
  85. (defun mode-motion-highlight-word (event)
  86.   "For use as the value of `mode-motion-hook' -- highlight word under mouse."
  87.   (mode-motion-highlight-internal
  88.    event
  89.    #'(lambda () (default-mouse-track-beginning-of-word nil))
  90.    #'(lambda () (default-mouse-track-end-of-word nil))))
  91.  
  92. (defun mode-motion-highlight-symbol (event)
  93.   "For use as the value of `mode-motion-hook' -- highlight symbol under mouse."
  94.   (mode-motion-highlight-internal
  95.    event
  96.    #'(lambda () (default-mouse-track-beginning-of-word t))
  97.    #'(lambda () (default-mouse-track-end-of-word t))))
  98.  
  99. (defun mode-motion-highlight-sexp (event)
  100.   "For use as the value of `mode-motion-hook' -- highlight form under mouse."
  101.   (mode-motion-highlight-internal
  102.    event
  103.    #'(lambda ()
  104.        (if (= (char-syntax (following-char)) ?\()
  105.        nil
  106.      (goto-char (scan-sexps (point) -1))))
  107.    #'(lambda ()
  108.        (if (= (char-syntax (following-char)) ?\))
  109.        (forward-char 1))
  110.        (goto-char (scan-sexps (point) 1)))))
  111.  
  112. (defun mode-motion-add-help-echo (event)
  113.   "For use as the value of `mode-motion-hook' -- add a 'help-echo property.
  114. This causes the string in the 'help-echo property to be displayed when the
  115. mouse moves over the extent.  See `mode-motion-help-echo-string' for
  116. documentation on how to control the string that is added."
  117.   (mode-motion-ensure-extent-ok event)
  118.   (let ((string (cond ((null mode-motion-help-echo-string) nil)
  119.               ((stringp mode-motion-help-echo-string)
  120.                mode-motion-help-echo-string)
  121.               (t (funcall mode-motion-help-echo-string event)))))
  122.     (if (stringp string)
  123.     (set-extent-property mode-motion-extent 'help-echo string))))
  124.  
  125.  
  126. ;;; Minibuffer hackery
  127.  
  128. (defun minibuf-mouse-tracker (event)
  129.   ;; Used as the mode-motion-hook of the minibuffer window, which is the
  130.   ;; value of `mouse-grabbed-buffer' while the minibuffer is active.  If
  131.   ;; the word under the mouse is a valid minibuffer completion, then it
  132.   ;; is highlighted.
  133.   ;;
  134.   ;; We do some special voodoo when we're reading a pathname, because
  135.   ;; the way filename completion works is funny.  Possibly there's some
  136.   ;; more general way this could be dealt with...
  137.   ;;
  138.   ;; We do some further voodoo when reading a pathname that is an
  139.   ;; ange-ftp or efs path, because causing FTP activity as a result of
  140.   ;; mouse motion is a really bad time.
  141.   ;;
  142.   (let ((filename-kludge-p (eq minibuffer-completion-table
  143.                    'read-file-name-internal)))
  144.     (mode-motion-highlight-internal
  145.      event
  146.      #'(lambda () (default-mouse-track-beginning-of-word
  147.            (if filename-kludge-p 'nonwhite t)))
  148.      #'(lambda ()
  149.     (let ((p (point))
  150.           (string ""))
  151.       (default-mouse-track-end-of-word (if filename-kludge-p 'nonwhite t))
  152.       (if (and (/= p (point)) minibuffer-completion-table)
  153.           (setq string (buffer-substring p (point))))
  154.       (if (string-match "\\`[ \t\n]*\\'" string)
  155.           (goto-char p)
  156.         (if filename-kludge-p
  157.         (setq string (minibuf-select-kludge-filename string)))
  158.         ;; try-completion bogusly returns a string even when that string
  159.         ;; is complete if that string is also a prefix for other
  160.         ;; completions.  This means that we can't just do the obvious
  161.         ;; thing, (eq t (try-completion ...)).
  162.         (let (comp)
  163.           (if (and filename-kludge-p
  164.                ;; #### evil evil evil evil
  165.                (or (and (fboundp 'ange-ftp-ftp-path)
  166.                 (ange-ftp-ftp-path string))
  167.                (and (fboundp 'efs-ftp-path)
  168.                 (efs-ftp-path string))))
  169.           (setq comp t)
  170.         (setq comp (try-completion string minibuffer-completion-table
  171.                        minibuffer-completion-predicate)))
  172.           (or (eq comp t)
  173.           (and (equal comp string)
  174.                (or (null minibuffer-completion-predicate)
  175.                (stringp minibuffer-completion-predicate) ; ???
  176.                (funcall minibuffer-completion-predicate
  177.                     (if (vectorp minibuffer-completion-table)
  178.                     (intern-soft string
  179.                      minibuffer-completion-table)
  180.                       string))))
  181.           (goto-char p)))))))))
  182.  
  183. (defun minibuf-select-kludge-filename (string)
  184.   (save-excursion
  185.     (set-buffer mouse-grabbed-buffer) ; the minibuf
  186.     (if (or (and (fboundp 'ange-ftp-ftp-path) (ange-ftp-ftp-path string))
  187.         (and (fboundp 'efs-ftp-path) (efs-ftp-path string)))
  188.     ;; #### evil evil evil, but more so.
  189.     string
  190.       (append-expand-filename (buffer-string) string))))
  191.  
  192. (defun minibuf-select-highlighted-completion (event)
  193.   "Select the highlighted text under the mouse as a minibuffer response.
  194. When the minibuffer is being used to prompt the user for a completion,
  195. any valid completions which are visible on the frame will highlight
  196. when the mouse moves over them.  Clicking \\<minibuffer-local-map>\
  197. \\[minibuf-select-highlighted-completion] will select the
  198. highlighted completion under the mouse.
  199.  
  200. If the mouse is clicked while while not over a highlighted completion,
  201. then the global binding of \\[minibuf-select-highlighted-completion] \
  202. will be executed instead.  In this\nway you can get at the normal global \
  203. behavior of \\[minibuf-select-highlighted-completion] as well as
  204. the special minibuffer behavior."
  205.   (interactive "e")
  206.   (minibuf-select-highlighted-completion-1 event t))
  207.  
  208. (defun minibuf-select-highlighted-completion-1 (event global-p)
  209.   (let ((filename-kludge-p (eq minibuffer-completion-table
  210.                    'read-file-name-internal))
  211.     completion
  212.     command-p)
  213.     (save-excursion
  214.       (let* ((buffer (window-buffer (event-window event)))
  215.          (p (event-point event))
  216.          (extent (and p (extent-at p buffer 'highlight))))
  217.     (set-buffer buffer)
  218.     (if (not (and (extent-live-p extent)
  219.               (eq (extent-buffer extent) (current-buffer))
  220.               (not (extent-detached-p extent))))
  221.         (setq command-p t)
  222.       ;; ...else user has selected a highlighted completion.
  223.       (setq completion
  224.         (buffer-substring (extent-start-position extent)
  225.                   (extent-end-position extent)))
  226.       (if filename-kludge-p
  227.           (setq completion (minibuf-select-kludge-filename completion)))
  228.       ;; remove the extent so that it's not hanging around in *Completions*
  229.       (detach-extent extent)
  230.       (set-buffer mouse-grabbed-buffer)
  231.       (erase-buffer)
  232.       (insert completion))))
  233.     ;; we need to execute the command or do the throw outside of the
  234.     ;; save-excursion.
  235.     (cond ((and command-p global-p)
  236.        (let ((command (lookup-key global-map
  237.                       (vector current-mouse-event))))
  238.          (if command
  239.          (call-interactively command)
  240.            (if minibuffer-completion-table
  241.            (error
  242.             "Highlighted words are valid completions.  You may select one.")
  243.          (error "no completions")))))
  244.       ((not command-p)
  245.        ;; things get confused if the minibuffer is terminated while
  246.        ;; not selected.
  247.        (select-window (minibuffer-window))
  248.        (if (and filename-kludge-p (file-directory-p completion))
  249.            ;; if the user clicked middle on a directory name, display the
  250.            ;; files in that directory.
  251.            (progn
  252.          (goto-char (point-max))
  253.          (minibuffer-completion-help))
  254.          ;; otherwise, terminate input
  255.          (throw 'exit nil))))))
  256.  
  257. (defun minibuf-maybe-select-highlighted-completion (event
  258.                             &optional click-count)
  259.   "Like minibuf-select-highlighted-completion but does nothing if there is
  260. no completion (as opposed to executing the global binding).  Useful as the
  261. value of `mouse-track-click-hook'."
  262.   (interactive "e")
  263.   (minibuf-select-highlighted-completion-1 event nil))
  264.  
  265. (define-key minibuffer-local-map 'button2
  266.   'minibuf-select-highlighted-completion)
  267.  
  268.  
  269. (provide 'mode-motion)
  270.