home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / x-sb-mouse / xsbm-userfuns.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  30.3 KB  |  876 lines
  1. ;;; xsbm-userfuns.el : bindable functions for x-sb-mouse
  2. ;;; Copyright (C) 1992 Sullivan Beck
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; The GNU General Public License is available by anonymouse ftp from
  15. ;;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
  16. ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
  17. ;;; USA.
  18. ;;--------------------------------------------------------------------
  19.  
  20. ;;; This file contains the user functions (i.e. functions designed
  21. ;;; specifically to be bound to mouse events).
  22.  
  23. ;;;**************************************************************************
  24. ;;;  MISC FUNCTIONS
  25.  
  26. ;; For SOME reason which I don't understand, when hyperbole requires
  27. ;; x-mouse, it redefines x-mouse-ignore to the old function in x-mouse.el
  28. ;; which requires a single argument.  This was goofing me up, so I have
  29. ;; made two functions: x-mouse-ignore which must have an argument (to
  30. ;; be compatible with the old version) and x--mouse-ignore which may
  31. ;; have an argument but doesn't need one.  I'll try to fix this sometime
  32. ;; if for no other reason then to get rid of the double dash (which I think
  33. ;; is ugly).
  34. (setq x-mouse-ignore
  35.       '((default . x--mouse-ignore)))
  36. (defun x--mouse-ignore (&optional arg)
  37.   "Do nothing."
  38.   ())
  39. (defun x-mouse-ignore (arg)
  40.   "Do nothing."
  41.   ())
  42.  
  43. (defun x-mouse-set-mark (&optional arg)
  44.   "Select the window that the mouse is on and set the mark at the mouse pos.
  45. The optional argument is to provide compatibility with x-mouse."
  46.   (let ((win ())
  47.         (mpos ())
  48.         (p0 ()))
  49.     (if arg
  50.         (setq win (x-mouse-window arg)
  51.               mpos (x-mouse-point arg))
  52.       (setq win x-mouse-win-u
  53.             mpos x-mouse-point-u))
  54.     (while (not (eq win (selected-window)))
  55.       (other-window 1))
  56.     (push-mark mpos t)))
  57.  
  58. (defun x-mouse-call-last-kbd-macro ()
  59.   "Moves the point to where the mouse cursor is and calls last keyboard macro.
  60. Uses x-mouse-set-point to set point."
  61.   (x-mouse-set-point)
  62.   (call-last-kbd-macro))
  63.  
  64. (defun x-mouse-execute-extended-command ()
  65.   "Executes a mouse command by name."
  66.   (setq func (read-minibuffer "Enter command: "))
  67.   (if (symbolp func)
  68.       (funcall (symbol-function func))
  69.     (message "Not a valid mouse function.")))
  70.  
  71. (defun x-mouse-describe-event (keyseq)
  72.   "Describes what function would be called by a mouse event (both down and up).
  73. Analogous to describe-key-briefly.  Lars Huttar 6/92."
  74.   (interactive "k(Describe what mouse event?)")
  75.                ; This key sequence should be C-c C-m or C-x C-@
  76.   (let ((defn (key-binding keyseq)))
  77.     (if (not (eq defn 'x-flush-mouse-queue)) ;; or maybe symbol-function ...
  78.         (error "Not a mouse event."))
  79.     (x-proc-mouse-event)) ;; handle the down event
  80.   (let ((defn (key-binding (read-key-sequence nil)))
  81.         (tmp x-mouse-describe-only)) ; save old value
  82.     (if (not (eq defn 'x-flush-mouse-queue)) ;; or maybe symbol-function ...
  83.         (error "Not a mouse event."))
  84.     (setq x-mouse-describe-only t)
  85.     (x-proc-mouse-event) ;; handle the up event, but don't actually do it.
  86.     (setq x-mouse-describe-only tmp)))
  87.  
  88.  
  89. ;;;**************************************************************************
  90. ;;;  SCROLLING/MOVEMENT COMMANDS
  91.  
  92. (defun x-mouse-set-point (&optional arg)
  93.   "This moves the point to where the mouse cursor is.
  94. It also stores the old point as the mark if x-mouse-auto-set-mark is
  95. non-nil unless arg is passed.  If arg is passed, it is using the old
  96. style x-mouse function which did not set the mark.  The optional argument
  97. is to provide compatibility with x-mouse.  Can be used as a drag in which
  98. case the position when you release the mouse is used."
  99.   (let ((win ())
  100.         (pos ())
  101.         (p0  ()))
  102.     (if arg
  103.         (setq win (x-mouse-window arg)
  104.               pos (x-mouse-point arg)
  105.               p0  (point))
  106.       (setq win x-mouse-win-u
  107.             pos x-mouse-point-u
  108.             p0  x-mouse-point-0))
  109.     (select-window win)
  110.     (goto-char pos)
  111.     (if (and (not arg) x-mouse-auto-set-mark (eq x-mouse-type-u 'window))
  112.         (push-mark p0))))
  113.  
  114. (defun x-mouse-scroll-down ()
  115.   "This scrolls the window down without selecting it."
  116.   (select-window x-mouse-win-u)
  117.   (condition-case nil
  118.       (scroll-down)
  119.     (beginning-of-buffer (message "Beginning of buffer")))
  120.   (select-window x-mouse-win-0))
  121.  
  122. (defun x-mouse-scroll-up ()
  123.   "This scrolls the window up without selecting it."
  124.   (select-window x-mouse-win-u)
  125.   (condition-case nil
  126.       (scroll-up)
  127.     (end-of-buffer (message "End of buffer")))
  128.   (select-window x-mouse-win-0))
  129.  
  130. (defun x-mouse-scroll-to-top ()
  131.   "Positions the mouse point at the top of the window.
  132. Does not select the window."
  133.   (x-mouse-set-point)
  134.   (recenter 0)
  135.   (select-window x-mouse-win-0))
  136.  
  137. (defun x-mouse-scroll-to-center ()
  138.   "Positions the mouse point at the center of the window.
  139. Does not select the window."
  140.   (x-mouse-set-point)
  141.   (recenter (1- (/ (window-height) 2)))
  142.   (select-window x-mouse-win-0))
  143.  
  144. (defun x-mouse-scroll-to-bottom ()
  145.   "Positions the mouse point at the bottom of the window.
  146. Does not select the window."
  147.   (x-mouse-set-point)
  148.   (recenter (- (window-height) 2))
  149.   (select-window x-mouse-win-0))
  150.  
  151. (defun x-mouse-scroll-to-proportion ()
  152.   "Goes to a point N% of the way from the top of the buffer.
  153. If the mouse release occurs at a point 4/5 of the way down the window or
  154. border, or 4/5 of the way along the mode line, it will go to the line 80%
  155. of the way through the file BY THE NUMBER OF LINES in the buffer, NOT the
  156. number of characters.  In other words, it will go to line 80 of a 100 line
  157. buffer regardless of how much of the actual text is above or below line 80.
  158. Can be used as a buffer, mode, or window click.  Does NOT select the window."
  159.   (let (nline line hei wid
  160.         (x   (car x-mouse-pos-u))
  161.         (y   (car (cdr x-mouse-pos-u))))
  162.     (x-mouse-select)
  163.     (setq hei (1- (window-height))
  164.           wid (window-width)
  165.           nline (count-lines (point-min) (point-max)))
  166.     (if (x-mouse-mode-p x-mouse-pos-u x-mouse-win-u)
  167.         (setq x (- x (nth 0 (window-edges x-mouse-win-u)))
  168.               line (/ (* x nline) (1- wid)))
  169.       (setq y (- y (nth 1 (window-edges x-mouse-win-u)))
  170.             line (/ (* y nline) (1- hei))))
  171.     (goto-line line)
  172.     (select-window x-mouse-win-0)))
  173.  
  174. (defun x-mouse-scroll-line ()
  175.   "Scroll line where mouse was pressed to where mouse was released.
  176. If a click is used, scrolls the line with the point to the position
  177. under the mouse point."
  178.   (let (y0 y1 pos)
  179.     (if x-mouse-click
  180.     (setq pos (x-mouse-pos x-mouse-win-u
  181.                    (save-window-excursion
  182.                  (select-window x-mouse-win-u)
  183.                  (point)))
  184.           y0 (nth 1 pos))
  185.       (setq y0 (nth 1 x-mouse-pos-d)))
  186.     (setq y1 (nth 1 x-mouse-pos-u))
  187.     (select-window x-mouse-win-u)
  188.     (goto-char (window-start))
  189.     (vertical-motion (- y0 y1))
  190.     (set-window-start x-mouse-win-u (point) t)
  191.     (select-window x-mouse-win-0)))
  192.  
  193.  
  194. ;;;**************************************************************************
  195. ;;;  WINDOW FUNCTIONS
  196.  
  197. (defun x-mouse-select (&optional arg)
  198.   "This selects the window clicked on.
  199. The optional argument is to provide compatibility with x-mouse."
  200.   (let ((coords ())
  201.         (win ()))
  202.     (if arg
  203.         (setq coords (x-mouse-coords arg)
  204.               win    (x-mouse-window arg))
  205.       (setq coords (x-mouse-coords x-mouse-pos-u)
  206.             win    x-mouse-win-u))
  207.     (select-window win)
  208.     coords))
  209.  
  210. (defun x-mouse-select-and-split (&optional arg)
  211.   "This selects the window under the mouse and splits it.
  212. The optional argument is to provide compatibility with x-mouse."
  213.   (if arg
  214.       (x-mouse-select arg)
  215.     (select-window x-mouse-win-u))
  216.   (split-window-vertically nil))
  217.  
  218. (defun x-mouse-keep-one-window (&optional arg)
  219.   "Selects the window under the mouse and kills all others.
  220. The optional argument is to provide compatibility with x-mouse."
  221.   (if arg
  222.       (x-mouse-select arg)
  223.     (select-window x-mouse-win-u))
  224.   (delete-other-windows))
  225.  
  226. (defun x-mouse-split-vertically ()
  227.   "Splits the window vertically placing the mode line here.
  228. This function should either be bound to a border or window click.  It
  229. will split this window (without selecting it) and put the mode line at
  230. this height."
  231.   (let* ((top (nth 1 (window-edges x-mouse-win-u)))
  232.      (y (car (cdr x-mouse-pos-u))))
  233.   (select-window x-mouse-win-u)
  234.   (split-window-vertically (1+ (- y top)))
  235.   (select-window x-mouse-win-0)))
  236.  
  237. (defun x-mouse-split-horizontally ()
  238.   "Splits the window horizontally placing the border line here.
  239. This function should either be bound to a mode or window click.  It
  240. will split this window (without selecting it) and put the border line at
  241. this position from the left."
  242.   (let* ((left (nth 0 (window-edges x-mouse-win-u)))
  243.      (x (car x-mouse-pos-u)))
  244.   (select-window x-mouse-win-u)
  245.   (split-window-horizontally (1+ (- x left)))
  246.   (select-window x-mouse-win-0)))
  247.  
  248. (defun x-mouse-delete-this-window ()
  249.   "Kills the window under the mouse."
  250.   (if (eq x-mouse-win-u x-mouse-win-0)
  251.       (delete-window)
  252.     (select-window x-mouse-win-u)
  253.     (delete-window)
  254.     (select-window x-mouse-win-0)))
  255.  
  256.  
  257. ;;;**************************************************************************
  258. ;;;  COPYING/CUTTING TEXT
  259.  
  260. (defun x-cut-text (arg &optional kill)
  261.   "This is just to be compatible with x-mouse.el."
  262.   (x-mouse-copy-text arg kill))
  263.  
  264. (defun x-mouse-copy-text (&optional arg kill)
  265.   "Copies the appropriate region to the X cut buffer.
  266. The optional arguments are to provide compatibility with x-mouse.  This
  267. function is appropriate either for a drag (arg=nil, x-mouse-click=nil,
  268. region defined by mouse drag), click (arg=nil, x-mouse-click=t, region
  269. defined by the mouse position and the point, both of which MUST be in
  270. the same window), and a call to the traditional x-cut-text function
  271. where arg=(x,y) and the region is defined the same way as a click.
  272. If x-mouse-duplicate-cut is non-nil, the region is also stored in the kill
  273. ring."
  274.   (let ((test t)
  275.         (win ())
  276.         (p0 ())
  277.         (p1 ()))
  278.     (if arg
  279.         (setq win (selected-window)
  280.               test (coordinates-in-window-p arg win)
  281.               p0 (point)
  282.               p1 (x-mouse-point arg))
  283.       (if x-mouse-click
  284.           (setq win (selected-window)
  285.                 test (coordinates-in-window-p x-mouse-pos-u win)
  286.                 p0 (point)
  287.                 p1 x-mouse-point-u)
  288.         (setq win x-mouse-win-u
  289.               p0 x-mouse-point-d
  290.               p1 x-mouse-point-u)))
  291.     (if test
  292.         (save-excursion
  293.           (set-buffer (window-buffer win))
  294.           (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1))
  295.           (x-store-cut-buffer (buffer-substring p0 p1))
  296.           (if kill (delete-region p0 p1)))
  297.       (message "Mouse not in selected window"))))
  298.  
  299. (defun x-paste-text (arg)
  300.   "This is to be compatible with x-mouse.el."
  301.   (x-mouse-paste-text arg))
  302.  
  303. (defun x-mouse-paste-text (&optional arg)
  304.   "This moves the point to the cursor position and pastes the X cut buffer.
  305. It also saves the old point as the mark if arg is not present (it does NOT
  306. save it if arg is present because x-mouse didn't save it).  The optional
  307. argument is to provide compatibility with x-mouse."
  308.   (if arg
  309.       (x-mouse-set-point arg)
  310.     (x-mouse-set-point)
  311.     (push-mark x-mouse-point-0))
  312.   (insert (x-get-cut-buffer)))
  313.  
  314. (defun x-cut-and-wipe-text (arg)
  315.   "This is to be compatible with x-mouse.el."
  316.   (x-mouse-cut-text arg))
  317.  
  318. (defun x-mouse-cut-text (&optional arg)
  319.   "This cuts the window drag section to the X cut buffer.
  320. The optional argument is to provide compatibility with x-mouse.  If
  321. x-mouse-duplicate-cut is non-nil, the section is also stored in the
  322. emacs kill ring."
  323.   (let ((p0 ())
  324.         (p1 ()))
  325.     (if arg
  326.         (x-cut-text arg t)
  327.       (save-excursion
  328.         (set-buffer (window-buffer x-mouse-win-u))
  329.         (if x-mouse-click
  330.             (setq p0 (point)
  331.                   p1 x-mouse-point-u)
  332.           (setq p0 x-mouse-point-d
  333.                 p1 x-mouse-point-u))
  334.         (x-store-cut-buffer (buffer-substring p0 p1))
  335.         (if x-mouse-duplicate-cut
  336.             (kill-region p0 p1)
  337.           (delete-region p0 p1))))))
  338.  
  339. (defun x-mouse-paste-there ()
  340.   "This pastes the X cut buffer at the point (NOT the mouse position).
  341. It does not select the window."
  342.   (save-window-excursion
  343.     (x-mouse-select)
  344.     (save-excursion
  345.       (insert (x-get-cut-buffer)))))
  346.  
  347. (defun x-mouse-append-drag ()
  348.   "This appends the drag to the X cut buffer.
  349. If x-mouse-duplicate-cut is non-nil, it is also appended to the kill ring."
  350.   (save-excursion
  351.     (set-buffer (window-buffer x-mouse-win-u))
  352.     (x-store-cut-buffer
  353.      (concat (x-get-cut-buffer)
  354.              (buffer-substring x-mouse-point-d x-mouse-point-u)))
  355.     (if x-mouse-duplicate-cut
  356.         (progn
  357.           (append-next-kill)
  358.           (copy-region-as-kill x-mouse-point-d x-mouse-point-u)))))
  359.  
  360. (defun x-mouse-copy-text-to-point ()
  361.   "This copies the drag to the point of the current window.
  362. When called as a click, it will copy the text between the mark and the
  363. mouse point."
  364.   (let ((p0 ())
  365.         (p1 ()))
  366.     (insert
  367.      (save-excursion
  368.        (set-buffer (window-buffer x-mouse-win-u))
  369.        (if x-mouse-click
  370.            (setq p0 (mark)
  371.                  p1 x-mouse-point-u)
  372.          (setq p0 x-mouse-point-d
  373.                p1 x-mouse-point-u))
  374.        (buffer-substring p0 p1)))))
  375.  
  376. (defun x-mouse-cut-text-to-point ()
  377.   "This cuts the drag to the point of the current window.
  378. When called as a click, it will cut the text between the mark and the
  379. mouse point."
  380.   (let ((p0 ())
  381.         (p1 ()))
  382.     (insert
  383.      (save-excursion
  384.        (set-buffer (window-buffer x-mouse-win-u))
  385.        (if x-mouse-click
  386.            (setq p0 (mark)
  387.                  p1 x-mouse-point-u)
  388.          (setq p0 x-mouse-point-d
  389.                p1 x-mouse-point-u))
  390.        (let ((tmp (buffer-substring p0 p1)))
  391.          (delete-region p0 p1)
  392.          tmp)))))
  393.  
  394. (defun x-mouse-yank-here ()
  395.   "This inserts the kill ring at the mouse point.
  396. It saves the old point as the mark."
  397.   (select-window x-mouse-win-u)
  398.   (goto-char x-mouse-point-u)
  399.   (push-mark x-mouse-point-0)
  400.   (yank))
  401.  
  402. (defun x-mouse-yank-there ()
  403.   "This inserts the kill ring at the point (NOT mouse position)."
  404.   (yank))
  405.  
  406. (defun x-mouse-copy-kill-to-x ()
  407.   "This copies the emacs kill buffer to the x kill buffer."
  408.   (x-store-cut-buffer (car kill-ring-yank-pointer)))
  409.  
  410. (defun x-mouse-copy-bol-to-x ()
  411.   "Copies from the mouse point to the beginning of the line to X cut-buffer."
  412.   (let (p0 p1)
  413.     (x-mouse-select)
  414.     (save-excursion
  415.       (x-mouse-set-point)
  416.       (setq p0 (save-excursion (beginning-of-line) (point))
  417.             p1 x-mouse-point-u)
  418.       (x-store-cut-buffer (buffer-substring p0 p1))
  419.       (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1))
  420.       (select-window x-mouse-win-0))))
  421.  
  422. (defun x-mouse-copy-line-to-x ()
  423.   "Copies the line under the mouse to the X cut-buffer."
  424.   (let (p0 p1)
  425.     (x-mouse-select)
  426.     (save-excursion
  427.       (x-mouse-set-point)
  428.       (setq p0 (save-excursion (beginning-of-line) (point))
  429.             p1 (save-excursion (end-of-line) (point)))
  430.       (x-store-cut-buffer (buffer-substring p0 p1))
  431.       (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1))
  432.       (select-window x-mouse-win-0))))
  433.  
  434. (defun x-mouse-copy-eol-to-x ()
  435.   "Copies from the mouse point to the end of the line to X cut-buffer."
  436.   (let (p0 p1)
  437.     (x-mouse-select)
  438.     (save-excursion
  439.       (x-mouse-set-point)
  440.       (setq p0 x-mouse-point-u
  441.             p1 (save-excursion (end-of-line) (point)))
  442.       (x-store-cut-buffer (buffer-substring p0 p1))
  443.       (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1))
  444.       (select-window x-mouse-win-0))))
  445.  
  446. (defun x-mouse-copy-rect-to-x ()
  447.   "This copies a rectangle to the x-cut-buffer."
  448.   (let (lines tmp j (i 0) (line "") p0 p1)
  449.     (if x-mouse-click
  450.         (setq p0 (point)
  451.               p1 x-mouse-point-u)
  452.       (setq p0 x-mouse-point-d
  453.             p1 x-mouse-point-u))
  454.     (if (< p1 p0)
  455.         (setq tmp p1
  456.               p1 p0
  457.               p0 tmp))
  458.     (setq j (operate-on-rectangle 'extract-rectangle-line p0 p1 nil)
  459.           lines (nreverse lines))
  460.     (while (< i j)
  461.       (setq line (concat line (nth i lines) "\n")
  462.             i (1+ i)))
  463.     (setq line (concat line (nth i lines)))
  464.     (x-store-cut-buffer line)))
  465.  
  466. (defun x-mouse-cut-rect-to-x ()
  467.   "This kills a rectangle to the x-cut-buffer."
  468.   (let (lines tmp j (i 0) (line "") p0 p1)
  469.     (if x-mouse-click
  470.         (setq p0 (point)
  471.               p1 x-mouse-point-u)
  472.       (setq p0 x-mouse-point-d
  473.             p1 x-mouse-point-u))
  474.     (if (< p1 p0)
  475.         (setq tmp p1
  476.               p1 p0
  477.               p0 tmp))
  478.     (setq j (operate-on-rectangle 'delete-extract-rectangle-line p0 p1 t)
  479.           lines (nreverse lines))
  480.     (while (<= i j)
  481.       (setq line (concat line (nth i lines) "\n")
  482.             i (1+ i)))
  483.     (x-store-cut-buffer line)))
  484.  
  485. (defun x-mouse-copy-rect-to-000 ()
  486.   "This copies the rectangle to register 0."
  487.   (let (p0 p1)
  488.     (if x-mouse-click
  489.         (setq p0 (point)
  490.               p1 x-mouse-point-u)
  491.       (setq p0 x-mouse-point-d
  492.             p1 x-mouse-point-u))
  493.     (if (< p1 p0)
  494.         (setq tmp p1
  495.               p1 p0
  496.               p0 tmp))
  497.     (copy-rectangle-to-register ?\000 p0 p1 nil)))
  498.  
  499. (defun x-mouse-cut-rect-to-000 ()
  500.   "This kills the rectangle to register 0."
  501.   (let (p0 p1)
  502.     (if x-mouse-click
  503.         (setq p0 (point)
  504.               p1 x-mouse-point-u)
  505.       (setq p0 x-mouse-point-d
  506.             p1 x-mouse-point-u))
  507.     (if (< p1 p0)
  508.         (setq tmp p1
  509.               p1 p0
  510.               p0 tmp))
  511.     (copy-rectangle-to-register ?\000 p0 p1 t)))
  512.  
  513. (defun x-mouse-open-rect ()
  514.   "This opens the rectangle."
  515.   (let (p0 p1)
  516.     (if x-mouse-click
  517.         (setq p0 (point)
  518.               p1 x-mouse-point-u)
  519.       (setq p0 x-mouse-point-d
  520.             p1 x-mouse-point-u))
  521.     (if (< p1 p0)
  522.         (setq tmp p1
  523.               p1 p0
  524.               p0 tmp))
  525.     (open-rectangle p0 p1)))
  526.  
  527. (defun x-mouse-insert-rect-000-here ()
  528.   "This inserts the rectangle stored in register 0 at mouse point."
  529.   (save-window-excursion
  530.     (save-excursion
  531.       (x-mouse-set-point)
  532.       (insert-register ?\000))))
  533.  
  534. (defun x-mouse-insert-rect-000 ()
  535.   "Moves point here and inserts the rectangle stored in register 0."
  536.   (x-mouse-set-point)
  537.   (insert-register ?\000))
  538.  
  539. (defun x-mouse-insert-rect-000-there ()
  540.   "Inserts the rectangle stored in register 0 at the point."
  541.   (insert-register ?\000))
  542.  
  543. (defun x-mouse-copy-thing ()
  544.   "Uses the thing package to copy the thing under the mouse.
  545. The thing is either a word or an s-expression of some kind.
  546. A left or right bracket, parenthese, or brace marks an expression.
  547. An opening double copies everything up to the next set of double quotes.
  548. The end of a line matches the whole line (excluding the newline)."
  549.   (select-window x-mouse-win-u)
  550.   (let* ((boundaries (thing-boundaries x-mouse-point-u))
  551.      (p0 (car boundaries))
  552.      (p1 (cdr boundaries)))
  553.     (x-store-cut-buffer (buffer-substring p0 p1))
  554.     (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1)))
  555.   (select-window x-mouse-win-0))
  556.  
  557. (defun x-mouse-cut-thing ()
  558.   "Uses the thing package to cut the thing under the mouse.
  559. The thing is either a word or sexp.  See x-mouse-copy-thing for a
  560. description of valid things."
  561.   (select-window x-mouse-win-u)
  562.   (let* ((boundaries (thing-boundaries x-mouse-point-u))
  563.      (p0 (car boundaries))
  564.      (p1 (cdr boundaries)))
  565.     (x-store-cut-buffer (buffer-substring p0 p1))
  566.     (if x-mouse-duplicate-cut (copy-region-as-kill p0 p1))
  567.     (delete-region p0 p1))
  568.   (select-window x-mouse-win-0))
  569.  
  570. (defun x-mouse-copy-thing-to-point ()
  571.   "Uses the thing package to copy the thing under the mouse to the point.
  572. The thing is either a word or sexp.  See x-mouse-copy-thing for a
  573. description of valid things."
  574.   (select-window x-mouse-win-u)
  575.   (let* ((boundaries (thing-boundaries x-mouse-point-u))
  576.      (p0 (car boundaries))
  577.      (p1 (cdr boundaries))
  578.      (tmp (buffer-substring p0 p1)))
  579.     (select-window x-mouse-win-0)
  580.     (insert tmp)))
  581.  
  582. (defun x-mouse-cut-thing-to-point ()
  583.   "Uses the thing package to cut the thing under the mouse to the point.
  584. The thing is either a word or sexp.  See x-mouse-copy-thing for a
  585. description of valid things."
  586.   (select-window x-mouse-win-u)
  587.   (let* ((boundaries (thing-boundaries x-mouse-point-u))
  588.      (p0 (car boundaries))
  589.      (p1 (cdr boundaries))
  590.      (tmp (buffer-substring p0 p1)))
  591.     (delete-region p0 p1)
  592.     (select-window x-mouse-win-0)
  593.     (insert tmp)))
  594.  
  595.  
  596. ;;;**************************************************************************
  597. ;;;  PUPUP MENU COMMANDS
  598.  
  599. (defun x-buffer-menu (arg)
  600.   "For compatibility with x-mouse.el."
  601.   (x-mouse-buffer-menu arg))
  602.  
  603. (defun x-mouse-buffer-menu (&optional arg)
  604.   "Pop up a menu of buffers for selection with the mouse.
  605. The optional argument is to provide compatibility with x-mouse."
  606.   (if (fboundp 'x-popup-menu)
  607.       (let* ((pos (if arg arg x-mouse-pos-u))
  608.              (menu ())
  609.              (title "Buffer Menu")
  610.              (menu-label "Select Buffer")
  611.              (bufflist (buffer-list))
  612.              (i 0)
  613.              (len (length bufflist))
  614.              (buff ())
  615.              (buff-name ()))
  616.         (while (< i len)
  617.           (setq buff (nth i bufflist)
  618.                 buff-name (buffer-name buff)
  619.                 i (1+ i))
  620.           (if (equal (char-to-string (elt buff-name 0)) " ")
  621.               ()
  622.             (setq buff-name (format " %25s   %s " buff-name
  623.                                     (or (buffer-file-name buff) ""))
  624.                   menu (append menu (list (cons buff-name buff))))))
  625.         (setq menu (list title (append (list menu-label) menu)))
  626.         (switch-to-buffer (or (x-popup-menu pos menu)
  627.                               (current-buffer))))
  628.     (buffer-menu nil)))
  629.  
  630. (defun x-help (arg)
  631.   "For compatibility with x-mouse.el."
  632.   (x-mouse-menu-help arg))
  633.  
  634. (defun x-mouse-menu-help (&optional arg)
  635.   "Enter a menu-based help system."
  636.   (if (fboundp 'x-popup-menu)
  637.       (let* ((pos (if arg arg x-mouse-pos-u))
  638.              (selection
  639.               (x-popup-menu
  640.                pos
  641.                '("Help" 
  642.                  ("Is there a command that..."
  643.                   ("Command apropos" . command-apropos)
  644.                   ("Apropos" . apropos))
  645.                  ("Key Commands <==> Functions"
  646.                   ("List all keystroke commands" . describe-bindings)
  647.                   ("Describe key briefly" . describe-key-briefly)
  648.                   ("Describe key verbose" . describe-key)
  649.                   ("Describe Lisp function" . describe-function)
  650.                   ("Where is this command" . where-is))
  651.                  ("Manual and tutorial"
  652.                   ("Info system" . info)
  653.                   ("Invoke Emacs tutorial" . help-with-tutorial))
  654.                  ("Odds and ends"
  655.                   ("Last 100 Keystrokes" . view-lossage)
  656.                   ("Describe syntax table" . describe-syntax))
  657.                  ("Modes"
  658.                   ("Describe current major mode" . describe-mode)
  659.                   ("List all keystroke commands" . describe-bindings))
  660.                  ("Administrivia"
  661.                   ("View Emacs news" . view-emacs-news)
  662.                   ("View the GNU Emacs license" . describe-copying)
  663.                   ("Describe distribution" . describe-distribution)
  664.                   ("Describe (non)warranty" . describe-no-warranty))))))
  665.         (and selection (call-interactively selection)))))
  666.  
  667. (defun x-mouse-help ()
  668.   "Pops up a menu or a *Mouse Help* buffer showing all mouse bindings.
  669. If menus are unavailable, it'll put the text in a *Help* buffer."
  670.   (let* ((menubase
  671.       (list
  672.        (list
  673.         "Keyboard Modifiers"
  674.         (cons "*     Default function    " ())
  675.         (cons "-     No keyboard modifier" ())
  676.         (cons "c     Control key         " ())
  677.         (cons "m     Meta (ESC) key      " ())
  678.         (cons "s     Shift key           " ())
  679.         (cons "" ())
  680.         (cons "" ())
  681.         (cons "A drag region is defines as the region between where" ())
  682.         (cons "the button was pressed and where it was released." ())
  683.         (cons "" ())
  684.         (cons "The X cut buffer is where X stores text in.  It is NOT" ())
  685.         (cons "the same as the kill ring where emacs stores cut and" ())
  686.         (cons "killed text." ())
  687.         (cons "" ())
  688.         (cons "" ())
  689.         (cons "Note:  Menu commands are only available if emacs was" ())
  690.         (cons "       compiled with HAVE_X_MENUS defined.  This is" ())
  691.         (cons "       NOT defined by default so you may have to" ())
  692.         (cons "       recompile emacs if you wish to use menus." ())
  693.         (cons "" ())
  694.         (cons "" ())
  695.         (cons "" ())
  696.         (cons "" ())
  697.         (cons "" ())
  698.         (cons "" ())
  699.         (cons "Select this to send this text to *Mouse Help* buffer."
  700.           "HelpBuffer"))))
  701.      (text '(lambda (var)
  702.           ;; Returns the first line of the function documentation
  703.           ;; for VAR of type "x-mouse-c1-window-click".
  704.           (x-mouse-get-function-doc var x-mouse-mode-u)))
  705.      (line '(lambda (func mods but where type)
  706.           ;; Returns a cons containing the description of function
  707.           ;; "x-mouse-MODS BUT-WHERE-TYPE" if it is not the
  708.           ;; same as the default function FUNC.
  709.           (let* ((but-var (concat "x-mouse-" mods but "-" where "-"
  710.                       type))
  711.              (but-func (x-mouse-get-function but-var
  712.                              x-mouse-mode-u))
  713.              spaces txt)
  714.             (if (eq but-func func) ()
  715.               (setq spaces (make-string (- 4 (length mods)) ?\ )
  716.                 txt (funcall text but-var))
  717.               (cons (concat spaces mods " " txt) ())))))
  718.      (typel '(lambda (but where type)
  719.            ;; Returns a list of cons cells, one for each button
  720.            ;; event (of TYPE) occuring in WHERE (ex. "border").
  721.            ;; The first one is the default function (no keyboard
  722.            ;; modifiers) and the remaining members are the
  723.            ;; events that are different then the default one.
  724.            (let* ((mods '["c" "m" "s" "cm" "cs" "ms" "cms"])
  725.               (i 0)
  726.               (but-var (concat "x-mouse-" but "-" where "-" type))
  727.               (but-func (x-mouse-get-function but-var
  728.                               x-mouse-mode-u))
  729.               aline list)
  730.              (while (< i 7)
  731.                (setq aline (funcall line but-func (aref mods i)
  732.                         but where type)
  733.                  i (1+ i))
  734.                (if aline
  735.                (setq list (append list (list aline)))))
  736.              (append (list (cons
  737.                     (concat "   * " (funcall text but-var))
  738.                     ()))
  739.                  list))))
  740.      (button '(lambda (but)
  741.             ;; Returns a list of cons cells, one for each button
  742.             ;; click event in each of the locations on the screen.
  743.             (let* ((where '["window" "mode" "border" "inter"
  744.                     "mini"])
  745.                (i 0)
  746.                list wh)
  747.               (while (< i 5)
  748.             (setq wh (aref where i)
  749.                   list (append
  750.                     list
  751.                     (list (cons " " ()))
  752.                     (list (cons (concat
  753.                          (capitalize wh)
  754.                          " Click") ()))
  755.                     (funcall typel but wh "click"))
  756.                   i (1+ i)))
  757.               (append (list (concat "*** BUTTON " but " ***"))
  758.                   (list (cons " " ()))
  759.                   list))))
  760.      (write '(lambda (list &optional spaces)
  761.            ;; Takes a list of lists and returns a string containing
  762.            ;; all the lists.
  763.            (let ((i 0) string len)
  764.              (if (listp list)
  765.              (if (listp (cdr list))
  766.                  (if (= (setq len (length list)) 1)
  767.                  (setq string
  768.                        (funcall write (nth 0 list) spaces))
  769.                    (if spaces (setq spaces (concat spaces "  "))
  770.                  (setq spaces "  "))
  771.                    (while (< i len)
  772.                  (setq string
  773.                        (concat string
  774.                            (funcall write (nth i list)
  775.                             spaces))
  776.                        i (1+ i))))
  777.                (setq string (concat spaces (nth 0 list))))
  778.                (setq string (concat spaces list "\n")))
  779.              string)))
  780.      (drag '(lambda ()
  781.           ;; Returns a list describing all drag functions.
  782.           (let* (list)
  783.             (setq list (append (list (cons "Button 1" ()))
  784.                        (list (cons " " ()))
  785.                        (funcall typel 1 "window" "drag")
  786.                        (list (cons " " ()))
  787.                        (list (cons "Button 2" ()))
  788.                        (list (cons " " ()))
  789.                        (funcall typel 2 "window" "drag")
  790.                        (list (cons " " ()))
  791.                        (list (cons "Button 3" ()))
  792.                        (list (cons " " ()))
  793.                        (funcall typel 3 "window" "drag")))
  794.             (append (list (concat "*** Window Drags ***"))
  795.                 list))))
  796.      menu tobuff)
  797.     (setq a0 menubase a1 text a2 line a3 typel a4 button a5 write a6 drag)
  798.     (if (and x-mouse-help-to-menu (fboundp 'x-popup-menu))
  799.     (progn
  800.       (setq menu
  801.         (append (list "Mouse Help")
  802.             menubase
  803.             (list (funcall button 1))
  804.             (list (funcall button 2))
  805.             (list (funcall button 3))
  806.             (list (funcall drag)))
  807.         tobuff
  808.         (x-popup-menu x-mouse-pos-u menu))
  809.       (if (string= tobuff "HelpBuffer")
  810.           (let ((x-mouse-help-to-menu nil))
  811.         (x-mouse-help))))
  812.       (with-output-to-temp-buffer "*Mouse-Help*"
  813.     (princ "Mouse Help\n\n")
  814.     (setq aaa menubase bbb write)
  815.     (princ (funcall write menubase))
  816.     (princ "\n")
  817.     (princ "\n")
  818.     (princ (funcall write (funcall button 1)))
  819.     (princ "\n")
  820.     (princ (funcall write (funcall button 2)))
  821.     (princ "\n")
  822.     (princ (funcall write (funcall button 3)))
  823.     (princ "\n")
  824.     (princ (funcall write (funcall drag)))))))
  825.  
  826. (defun x-mouse-files ()
  827.   (let* ((buffer (get-buffer-create "*TEMP*"))
  828.      (file-name (buffer-file-name (current-buffer)))
  829.      (dir-name (and file-name (file-name-directory file-name))))
  830.     (if (null dir-name)
  831.     (ding)
  832.       (save-excursion
  833.     (set-buffer buffer)
  834.     ;;
  835.     ;; Use directory-files?!?
  836.     ;;
  837.     (call-process "ls" nil buffer nil "-F" dir-name)
  838.     (prog1
  839.         (x-mouse-pick-files (string-to-strings (buffer-string)))
  840.       (erase-buffer)
  841.       (set-buffer-modified-p nil))))))
  842. (defun x-mouse-pick-files (files)
  843.   (let (filtered-files)
  844.     (while files
  845.       (if (not (string-match x-mouse-file-ignore-regexp (car files)))
  846.       (setq filtered-files
  847.         (cons (cons (car files) (car files)) filtered-files)))
  848.       (setq files (cdr files)))
  849.     (reverse filtered-files)))
  850. (defun string-to-strings (string &optional delimiter-regexp)
  851.   (or delimiter-regexp
  852.       (setq delimiter-regexp "[^ \n\t]+"))
  853.   (let ((start 0)
  854.     end
  855.     strings)
  856.     (while (setq start (string-match delimiter-regexp string start))
  857.       (setq end (match-end 0))
  858.       (setq strings (cons (substring string start end) strings))
  859.       (setq start end))
  860.     (reverse strings)))
  861. (defun x-mouse-get-file ()
  862.   "Pop up a menu of files in cwd for selection with the mouse.
  863. The optional argument is to provide compatibility with x-mouse."
  864.   (if (fboundp 'x-popup-menu)
  865.       (let* ((files (x-mouse-files))
  866.          (file (and files
  867.             (x-popup-menu x-mouse-pos-u
  868.                       (list "File Menu"
  869.                         (append (list "Select File")
  870.                             files))))))
  871.     (if file
  872.         (find-file file)))
  873.     (find-file "")))
  874.  
  875.  
  876.