0
|
1 ;;; Mouse related functions and commands
|
|
2 ;;; Copyright (C) 1995 Kyle E. Jones
|
|
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 ;;; You should have received a copy of the GNU General Public License
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
17
|
|
18 (provide 'vm-mouse)
|
|
19
|
|
20 (defun vm-mouse-fsfemacs-mouse-p ()
|
|
21 (and (vm-fsfemacs-19-p)
|
|
22 (fboundp 'set-mouse-position)))
|
|
23
|
|
24 (defun vm-mouse-xemacs-mouse-p ()
|
|
25 (and (vm-xemacs-p)
|
|
26 (fboundp 'set-mouse-position)))
|
|
27
|
|
28 (defun vm-mouse-set-mouse-track-highlight (start end)
|
|
29 (cond ((fboundp 'make-overlay)
|
|
30 (let ((o (make-overlay start end)))
|
|
31 (overlay-put o 'mouse-face 'highlight)))
|
|
32 ((fboundp 'make-extent)
|
|
33 (let ((o (make-extent start end)))
|
|
34 (set-extent-property o 'highlight t)))))
|
|
35
|
|
36 (defun vm-mouse-button-2 (event)
|
|
37 (interactive "e")
|
|
38 ;; go to where the event occurred
|
|
39 (cond ((vm-mouse-xemacs-mouse-p)
|
|
40 (set-buffer (window-buffer (event-window event)))
|
|
41 (and (event-point event) (goto-char (event-point event))))
|
|
42 ((vm-mouse-fsfemacs-mouse-p)
|
|
43 (set-buffer (window-buffer (posn-window (event-start event))))
|
|
44 (goto-char (posn-point (event-start event)))))
|
|
45 ;; now dispatch depending on where we are
|
|
46 (cond ((eq major-mode 'vm-summary-mode)
|
|
47 (mouse-set-point event)
|
|
48 (beginning-of-line)
|
|
49 (if (let ((vm-follow-summary-cursor t))
|
|
50 (vm-follow-summary-cursor))
|
|
51 (progn
|
|
52 (vm-select-folder-buffer)
|
|
53 (vm-preview-current-message))
|
|
54 (setq this-command 'vm-scroll-forward)
|
|
55 (call-interactively 'vm-scroll-forward)))
|
|
56 ((memq major-mode '(vm-mode vm-virtual-mode))
|
|
57 (cond ((and (vm-mouse-fsfemacs-mouse-p) vm-url-browser)
|
|
58 (vm-mouse-popup-or-select event))))))
|
|
59
|
|
60 (defun vm-mouse-button-3 (event)
|
|
61 (interactive "e")
|
|
62 (if vm-use-menus
|
|
63 (progn
|
|
64 ;; go to where the event occurred
|
|
65 (cond ((vm-mouse-xemacs-mouse-p)
|
|
66 (set-buffer (window-buffer (event-window event)))
|
|
67 (and (event-point event) (goto-char (event-point event))))
|
|
68 ((vm-mouse-fsfemacs-mouse-p)
|
|
69 (set-buffer (window-buffer (posn-window (event-start event))))
|
|
70 (goto-char (posn-point (event-start event)))))
|
|
71 ;; now dispatch depending on where we are
|
|
72 (cond ((eq major-mode 'vm-summary-mode)
|
|
73 (vm-menu-popup-mode-menu event))
|
|
74 ((eq major-mode 'vm-mode)
|
|
75 (vm-menu-popup-context-menu event))
|
|
76 ((eq major-mode 'vm-virtual-mode)
|
|
77 (vm-menu-popup-context-menu event))
|
|
78 ((eq major-mode 'mail-mode)
|
|
79 (vm-menu-popup-mode-menu event))))))
|
|
80
|
|
81 (defun vm-mouse-3-help (object)
|
|
82 "Use mouse button 3 to see a menu of options.")
|
|
83
|
|
84 (defun vm-mouse-get-mouse-track-string (event)
|
|
85 (save-excursion
|
|
86 ;; go to where the event occurred
|
|
87 (cond ((vm-mouse-xemacs-mouse-p)
|
|
88 (set-buffer (window-buffer (event-window event)))
|
|
89 (and (event-point event) (goto-char (event-point event))))
|
|
90 ((vm-mouse-fsfemacs-mouse-p)
|
|
91 (set-buffer (window-buffer (posn-window (event-start event))))
|
|
92 (goto-char (posn-point (event-start event)))))
|
|
93 (cond ((fboundp 'overlays-at)
|
|
94 (let ((o-list (overlays-at (point)))
|
|
95 (string nil))
|
|
96 (while o-list
|
|
97 (if (overlay-get (car o-list) 'mouse-face)
|
|
98 (setq string (vm-buffer-substring-no-properties
|
|
99 (overlay-start (car o-list))
|
|
100 (overlay-end (car o-list)))
|
|
101 o-list nil)
|
|
102 (setq o-list (cdr o-list))))
|
|
103 string ))
|
|
104 ((fboundp 'extent-at)
|
|
105 (let ((e (extent-at (point) nil 'highlight)))
|
|
106 (if e
|
|
107 (buffer-substring (extent-start-position e)
|
|
108 (extent-end-position e))
|
|
109 nil)))
|
|
110 (t nil))))
|
|
111
|
|
112 (defun vm-mouse-popup-or-select (event)
|
|
113 (interactive "e")
|
|
114 (cond ((vm-mouse-fsfemacs-mouse-p)
|
|
115 (set-buffer (window-buffer (posn-window (event-start event))))
|
|
116 (goto-char (posn-point (event-start event)))
|
|
117 (let (o-list o menu (found nil))
|
|
118 (setq o-list (overlays-at (point)))
|
|
119 (while (and o-list (not found))
|
|
120 (cond ((overlay-get (car o-list) 'vm-url)
|
|
121 (setq found t)
|
|
122 (vm-mouse-send-url-at-event event)))
|
|
123 (setq o-list (cdr o-list)))
|
|
124 (and (not found) (vm-menu-popup-context-menu event))))
|
|
125 ;; The XEmacs code is not actually used now, since all
|
|
126 ;; selectable objects are handled by an extent keymap
|
|
127 ;; binding that points to a more specific function. But
|
|
128 ;; this might come in handy later if I want selectable
|
|
129 ;; objects that don't have an extent attached.
|
|
130 ((vm-mouse-xemacs-mouse-p)
|
|
131 (set-buffer (window-buffer (event-window event)))
|
|
132 (and (event-point event) (goto-char (event-point event)))
|
|
133 (if (extent-at (point) (current-buffer) 'vm-url)
|
|
134 (vm-mouse-send-url-at-event event)
|
|
135 (vm-menu-popup-context-menu event)))))
|
|
136
|
|
137 (defun vm-mouse-send-url-at-event (event)
|
|
138 (interactive "e")
|
|
139 (cond ((vm-mouse-xemacs-mouse-p)
|
|
140 (set-buffer (window-buffer (event-window event)))
|
|
141 (and (event-point event) (goto-char (event-point event)))
|
|
142 (vm-mouse-send-url-at-position (event-point event)))
|
|
143 ((vm-mouse-fsfemacs-mouse-p)
|
|
144 (set-buffer (window-buffer (posn-window (event-start event))))
|
|
145 (goto-char (posn-point (event-start event)))
|
|
146 (vm-mouse-send-url-at-position (posn-point (event-start event))))))
|
|
147
|
|
148 (defun vm-mouse-send-url-at-position (pos &optional browser)
|
|
149 (cond ((vm-mouse-xemacs-mouse-p)
|
|
150 (let ((e (extent-at pos (current-buffer) 'vm-url))
|
|
151 url)
|
|
152 (if (null e)
|
|
153 nil
|
|
154 (setq url (buffer-substring (extent-start-position e)
|
|
155 (extent-end-position e)))
|
|
156 (vm-mouse-send-url url browser))))
|
|
157 ((vm-mouse-fsfemacs-mouse-p)
|
|
158 (let (o-list url o)
|
|
159 (setq o-list (overlays-at pos))
|
|
160 (while (and o-list (null (overlay-get (car o-list) 'vm-url)))
|
|
161 (setq o-list (cdr o-list)))
|
|
162 (if (null o-list)
|
|
163 nil
|
|
164 (setq o (car o-list))
|
|
165 (setq url (vm-buffer-substring-no-properties
|
|
166 (overlay-start o)
|
|
167 (overlay-end o)))
|
|
168 (vm-mouse-send-url url browser))))))
|
|
169
|
|
170 (defun vm-mouse-send-url (url &optional browser)
|
|
171 (let ((browser (or browser vm-url-browser)))
|
|
172 (cond ((symbolp browser)
|
|
173 (funcall browser url))
|
|
174 ((stringp browser)
|
|
175 (vm-unsaved-message "Sending URL to %s..." browser)
|
|
176 (vm-run-background-command browser url)
|
|
177 (vm-unsaved-message "Sending URL to %s... done" browser)))))
|
|
178
|
|
179 (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window)
|
|
180 (vm-unsaved-message "Sending URL to Netscape...")
|
|
181 (if new-netscape
|
|
182 (vm-run-background-command vm-netscape-program url)
|
|
183 (or (equal 0 (vm-run-command vm-netscape-program "-remote"
|
|
184 (concat "openURL(" url
|
|
185 (if new-window ", new-window" "")
|
|
186 ")")))
|
|
187 (vm-mouse-send-url-to-netscape url t new-window)))
|
|
188 (vm-unsaved-message "Sending URL to Netscape... done"))
|
|
189
|
|
190 (defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window)
|
|
191 (vm-unsaved-message "Sending URL to Mosaic...")
|
|
192 (if (null new-mosaic)
|
|
193 (let ((pid-file "~/.mosaicpid")
|
|
194 (work-buffer " *mosaic work*")
|
|
195 pid)
|
|
196 (cond ((file-exists-p pid-file)
|
|
197 (set-buffer (get-buffer-create work-buffer))
|
|
198 (erase-buffer)
|
|
199 (insert-file-contents pid-file)
|
|
200 (setq pid (int-to-string (string-to-int (buffer-string))))
|
|
201 (erase-buffer)
|
|
202 (insert (if new-window "newwin" "goto") ?\n)
|
|
203 (insert url ?\n)
|
|
204 (write-region (point-min) (point-max)
|
|
205 (concat "/tmp/Mosaic." pid)
|
|
206 nil 0)
|
|
207 (set-buffer-modified-p nil)
|
|
208 (kill-buffer work-buffer)))
|
|
209 (cond ((or (null pid)
|
|
210 (not (equal 0 (vm-run-command "kill" "-USR1" pid))))
|
|
211 (setq new-mosaic t)))))
|
|
212 (if new-mosaic
|
|
213 (vm-run-background-command vm-mosaic-program url))
|
|
214 (vm-unsaved-message "Sending URL to Mosaic... done"))
|
|
215
|
|
216
|
|
217 (defun vm-mouse-install-mouse ()
|
|
218 (cond ((vm-mouse-xemacs-mouse-p)
|
|
219 (if (null (lookup-key vm-mode-map 'button2))
|
|
220 (define-key vm-mode-map 'button2 'vm-mouse-button-2)))
|
|
221 ((vm-mouse-fsfemacs-mouse-p)
|
|
222 (if (null (lookup-key vm-mode-map [mouse-2]))
|
|
223 (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2))
|
|
224 (if (null (lookup-key vm-mode-map [down-mouse-3]))
|
|
225 (progn
|
|
226 (define-key vm-mode-map [mouse-3] 'ignore)
|
|
227 (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3))))))
|
|
228
|
|
229 (defun vm-run-background-command (command &rest arg-list)
|
|
230 (apply (function call-process) command nil 0 nil arg-list))
|
|
231
|
|
232 (defun vm-run-command (command &rest arg-list)
|
|
233 (apply (function call-process) command nil nil nil arg-list))
|
|
234
|
|
235 ;; stupid yammering compiler
|
|
236 (defvar vm-mouse-read-file-name-prompt)
|
|
237 (defvar vm-mouse-read-file-name-dir)
|
|
238 (defvar vm-mouse-read-file-name-default)
|
|
239 (defvar vm-mouse-read-file-name-must-match)
|
|
240 (defvar vm-mouse-read-file-name-initial)
|
|
241 (defvar vm-mouse-read-file-name-history)
|
|
242 (defvar vm-mouse-read-file-name-return-value)
|
|
243
|
|
244 (defun vm-mouse-read-file-name (prompt &optional dir default
|
|
245 must-match initial history)
|
|
246 "Like read-file-name, except uses a mouse driven interface.
|
|
247 HISTORY argument is ignored."
|
|
248 (save-excursion
|
|
249 (or dir (setq dir default-directory))
|
|
250 (set-buffer (generate-new-buffer " *Files*"))
|
|
251 (use-local-map (make-sparse-keymap))
|
|
252 (setq buffer-read-only t
|
|
253 default-directory dir)
|
|
254 (make-local-variable 'vm-mouse-read-file-name-prompt)
|
|
255 (make-local-variable 'vm-mouse-read-file-name-dir)
|
|
256 (make-local-variable 'vm-mouse-read-file-name-default)
|
|
257 (make-local-variable 'vm-mouse-read-file-name-must-match)
|
|
258 (make-local-variable 'vm-mouse-read-file-name-initial)
|
|
259 (make-local-variable 'vm-mouse-read-file-name-history)
|
|
260 (make-local-variable 'vm-mouse-read-file-name-return-value)
|
|
261 (setq vm-mouse-read-file-name-prompt prompt)
|
|
262 (setq vm-mouse-read-file-name-dir dir)
|
|
263 (setq vm-mouse-read-file-name-default default)
|
|
264 (setq vm-mouse-read-file-name-must-match must-match)
|
|
265 (setq vm-mouse-read-file-name-initial initial)
|
|
266 (setq vm-mouse-read-file-name-history history)
|
|
267 (setq vm-mouse-read-file-name-prompt prompt)
|
|
268 (setq vm-mouse-read-file-name-return-value nil)
|
|
269 (save-excursion
|
|
270 (vm-goto-new-frame 'completion))
|
|
271 (switch-to-buffer (current-buffer))
|
|
272 (vm-mouse-read-file-name-event-handler)
|
|
273 (save-excursion
|
|
274 (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler)
|
|
275 (recursive-edit))
|
|
276 ;; buffer could have been killed
|
|
277 (and (boundp 'vm-mouse-read-file-name-return-value)
|
|
278 (prog1
|
|
279 vm-mouse-read-file-name-return-value
|
|
280 (kill-buffer (current-buffer))))))
|
|
281
|
|
282 (defun vm-mouse-read-file-name-event-handler (&optional string)
|
|
283 (let ((key-doc "Click here for keyboard interface.")
|
|
284 start list)
|
|
285 (if string
|
|
286 (cond ((equal string key-doc)
|
|
287 (condition-case nil
|
|
288 (save-excursion
|
|
289 (save-excursion
|
|
290 (let ((vm-mutable-frames t))
|
|
291 (vm-delete-windows-or-frames-on (current-buffer))))
|
|
292 (setq vm-mouse-read-file-name-return-value
|
|
293 (vm-keyboard-read-file-name
|
|
294 vm-mouse-read-file-name-prompt
|
|
295 vm-mouse-read-file-name-dir
|
|
296 vm-mouse-read-file-name-default
|
|
297 vm-mouse-read-file-name-must-match
|
|
298 vm-mouse-read-file-name-initial
|
|
299 vm-mouse-read-file-name-history))
|
|
300 (vm-mouse-read-file-name-quit-handler t))
|
|
301 (quit (vm-mouse-read-file-name-quit-handler))))
|
|
302 ((file-directory-p string)
|
|
303 (setq default-directory (expand-file-name string)))
|
|
304 (t (setq vm-mouse-read-file-name-return-value
|
|
305 (expand-file-name string))
|
|
306 (vm-mouse-read-file-name-quit-handler t))))
|
|
307 (setq buffer-read-only nil)
|
|
308 (erase-buffer)
|
|
309 (setq start (point))
|
|
310 (insert vm-mouse-read-file-name-prompt)
|
|
311 (vm-set-region-face start (point) 'bold)
|
|
312 (cond ((and (not string) vm-mouse-read-file-name-default)
|
|
313 (setq start (point))
|
|
314 (insert vm-mouse-read-file-name-default)
|
|
315 (vm-mouse-set-mouse-track-highlight start (point)))
|
|
316 ((not string) nil)
|
|
317 (t (insert default-directory)))
|
|
318 (insert ?\n ?\n)
|
|
319 (setq start (point))
|
|
320 (insert key-doc)
|
|
321 (vm-mouse-set-mouse-track-highlight start (point))
|
|
322 (vm-set-region-face start (point) 'italic)
|
|
323 (insert ?\n ?\n)
|
|
324 (setq list (directory-files default-directory))
|
|
325 (vm-show-list list 'vm-mouse-read-file-name-event-handler)
|
|
326 (setq buffer-read-only t)))
|
|
327
|
|
328 (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit)
|
|
329 (interactive)
|
|
330 (let ((vm-mutable-frames t))
|
|
331 (vm-delete-windows-or-frames-on (current-buffer))
|
|
332 (if normal-exit
|
|
333 (throw 'exit nil)
|
|
334 (throw 'exit t))))
|
|
335
|
|
336 (defvar vm-mouse-read-string-prompt)
|
|
337 (defvar vm-mouse-read-string-completion-list)
|
|
338 (defvar vm-mouse-read-string-multi-word)
|
|
339 (defvar vm-mouse-read-string-return-value)
|
|
340
|
|
341 (defun vm-mouse-read-string (prompt completion-list &optional multi-word)
|
|
342 (save-excursion
|
|
343 (set-buffer (generate-new-buffer " *Choices*"))
|
|
344 (use-local-map (make-sparse-keymap))
|
|
345 (setq buffer-read-only t)
|
|
346 (make-local-variable 'vm-mouse-read-string-prompt)
|
|
347 (make-local-variable 'vm-mouse-read-string-completion-list)
|
|
348 (make-local-variable 'vm-mouse-read-string-multi-word)
|
|
349 (make-local-variable 'vm-mouse-read-string-return-value)
|
|
350 (setq vm-mouse-read-string-prompt prompt)
|
|
351 (setq vm-mouse-read-string-completion-list completion-list)
|
|
352 (setq vm-mouse-read-string-multi-word multi-word)
|
|
353 (setq vm-mouse-read-string-return-value nil)
|
|
354 (save-excursion
|
|
355 (vm-goto-new-frame 'completion))
|
|
356 (switch-to-buffer (current-buffer))
|
|
357 (vm-mouse-read-string-event-handler)
|
|
358 (save-excursion
|
|
359 (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler)
|
|
360 (recursive-edit))
|
|
361 ;; buffer could have been killed
|
|
362 (and (boundp 'vm-mouse-read-string-return-value)
|
|
363 (prog1
|
|
364 (if (listp vm-mouse-read-string-return-value)
|
|
365 (mapconcat 'identity vm-mouse-read-string-return-value " ")
|
|
366 vm-mouse-read-string-return-value)
|
|
367 (kill-buffer (current-buffer))))))
|
|
368
|
|
369 (defun vm-mouse-read-string-event-handler (&optional string)
|
|
370 (let ((key-doc "Click here for keyboard interface.")
|
|
371 (bs-doc " .... to go back one word.")
|
|
372 (done-doc " .... to when you're done.")
|
|
373 start list)
|
|
374 (if string
|
|
375 (cond ((equal string key-doc)
|
|
376 (condition-case nil
|
|
377 (save-excursion
|
|
378 (save-excursion
|
|
379 (let ((vm-mutable-frames t))
|
|
380 (vm-delete-windows-or-frames-on (current-buffer))))
|
|
381 (setq vm-mouse-read-string-return-value
|
|
382 (vm-keyboard-read-string
|
|
383 vm-mouse-read-string-prompt
|
|
384 vm-mouse-read-string-completion-list
|
|
385 vm-mouse-read-string-multi-word))
|
|
386 (vm-mouse-read-string-quit-handler t))
|
|
387 (quit (vm-mouse-read-string-quit-handler))))
|
|
388 ((equal string bs-doc)
|
|
389 (setq vm-mouse-read-string-return-value
|
|
390 (nreverse
|
|
391 (cdr
|
|
392 (nreverse vm-mouse-read-string-return-value)))))
|
|
393 ((equal string done-doc)
|
|
394 (vm-mouse-read-string-quit-handler t))
|
|
395 (t (setq vm-mouse-read-string-return-value
|
|
396 (nconc vm-mouse-read-string-return-value
|
|
397 (list string)))
|
|
398 (if (null vm-mouse-read-string-multi-word)
|
|
399 (vm-mouse-read-string-quit-handler t)))))
|
|
400 (setq buffer-read-only nil)
|
|
401 (erase-buffer)
|
|
402 (setq start (point))
|
|
403 (insert vm-mouse-read-string-prompt)
|
|
404 (vm-set-region-face start (point) 'bold)
|
|
405 (insert (mapconcat 'identity vm-mouse-read-string-return-value " "))
|
|
406 (insert ?\n ?\n)
|
|
407 (setq start (point))
|
|
408 (insert key-doc)
|
|
409 (vm-mouse-set-mouse-track-highlight start (point))
|
|
410 (vm-set-region-face start (point) 'italic)
|
|
411 (insert ?\n)
|
|
412 (if vm-mouse-read-string-multi-word
|
|
413 (progn
|
|
414 (setq start (point))
|
|
415 (insert bs-doc)
|
|
416 (vm-mouse-set-mouse-track-highlight start (point))
|
|
417 (vm-set-region-face start (point) 'italic)
|
|
418 (insert ?\n)
|
|
419 (setq start (point))
|
|
420 (insert done-doc)
|
|
421 (vm-mouse-set-mouse-track-highlight start (point))
|
|
422 (vm-set-region-face start (point) 'italic)
|
|
423 (insert ?\n)))
|
|
424 (insert ?\n)
|
|
425 (vm-show-list vm-mouse-read-string-completion-list
|
|
426 'vm-mouse-read-string-event-handler)
|
|
427 (setq buffer-read-only t)))
|
|
428
|
|
429 (defun vm-mouse-read-string-quit-handler (&optional normal-exit)
|
|
430 (interactive)
|
|
431 (let ((vm-mutable-frames t))
|
|
432 (vm-delete-windows-or-frames-on (current-buffer))
|
|
433 (if normal-exit
|
|
434 (throw 'exit nil)
|
|
435 (throw 'exit t))))
|