Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mouse.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; Mouse related functions and commands 1 ;;; Mouse related functions and commands
2 ;;; Copyright (C) 1995 Kyle E. Jones 2 ;;; Copyright (C) 1995-1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
46 (cond ((eq major-mode 'vm-summary-mode) 46 (cond ((eq major-mode 'vm-summary-mode)
47 (mouse-set-point event) 47 (mouse-set-point event)
48 (beginning-of-line) 48 (beginning-of-line)
49 (if (let ((vm-follow-summary-cursor t)) 49 (if (let ((vm-follow-summary-cursor t))
50 (vm-follow-summary-cursor)) 50 (vm-follow-summary-cursor))
51 (progn 51 nil
52 (vm-select-folder-buffer)
53 (vm-preview-current-message))
54 (setq this-command 'vm-scroll-forward) 52 (setq this-command 'vm-scroll-forward)
55 (call-interactively 'vm-scroll-forward))) 53 (call-interactively 'vm-scroll-forward)))
56 ((memq major-mode '(vm-mode vm-virtual-mode)) 54 ((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode))
57 (cond ((and (vm-mouse-fsfemacs-mouse-p) vm-url-browser) 55 (vm-mouse-popup-or-select event))))
58 (vm-mouse-popup-or-select event))))))
59 56
60 (defun vm-mouse-button-3 (event) 57 (defun vm-mouse-button-3 (event)
61 (interactive "e") 58 (interactive "e")
62 (if vm-use-menus 59 (if vm-use-menus
63 (progn 60 (progn
71 ;; now dispatch depending on where we are 68 ;; now dispatch depending on where we are
72 (cond ((eq major-mode 'vm-summary-mode) 69 (cond ((eq major-mode 'vm-summary-mode)
73 (vm-menu-popup-mode-menu event)) 70 (vm-menu-popup-mode-menu event))
74 ((eq major-mode 'vm-mode) 71 ((eq major-mode 'vm-mode)
75 (vm-menu-popup-context-menu event)) 72 (vm-menu-popup-context-menu event))
73 ((eq major-mode 'vm-presentation-mode)
74 (vm-menu-popup-context-menu event))
76 ((eq major-mode 'vm-virtual-mode) 75 ((eq major-mode 'vm-virtual-mode)
77 (vm-menu-popup-context-menu event)) 76 (vm-menu-popup-context-menu event))
78 ((eq major-mode 'mail-mode) 77 ((eq major-mode 'mail-mode)
79 (vm-menu-popup-mode-menu event)))))) 78 (vm-menu-popup-mode-menu event))))))
80 79
81 (defun vm-mouse-3-help (object) 80 (defun vm-mouse-3-help (object)
81 nil
82 "Use mouse button 3 to see a menu of options.") 82 "Use mouse button 3 to see a menu of options.")
83 83
84 (defun vm-mouse-get-mouse-track-string (event) 84 (defun vm-mouse-get-mouse-track-string (event)
85 (save-excursion 85 (save-excursion
86 ;; go to where the event occurred 86 ;; go to where the event occurred
112 (defun vm-mouse-popup-or-select (event) 112 (defun vm-mouse-popup-or-select (event)
113 (interactive "e") 113 (interactive "e")
114 (cond ((vm-mouse-fsfemacs-mouse-p) 114 (cond ((vm-mouse-fsfemacs-mouse-p)
115 (set-buffer (window-buffer (posn-window (event-start event)))) 115 (set-buffer (window-buffer (posn-window (event-start event))))
116 (goto-char (posn-point (event-start event))) 116 (goto-char (posn-point (event-start event)))
117 (let (o-list o menu (found nil)) 117 (let (o-list (found nil))
118 (setq o-list (overlays-at (point))) 118 (setq o-list (overlays-at (point)))
119 (while (and o-list (not found)) 119 (while (and o-list (not found))
120 (cond ((overlay-get (car o-list) 'vm-url) 120 (cond ((overlay-get (car o-list) 'vm-url)
121 (setq found t) 121 (setq found t)
122 (vm-mouse-send-url-at-event event))) 122 (vm-mouse-send-url-at-event event))
123 ((overlay-get (car o-list) 'vm-mime-function)
124 (setq found t)
125 (funcall (overlay-get (car o-list) 'vm-mime-function)
126 (car o-list))))
123 (setq o-list (cdr o-list))) 127 (setq o-list (cdr o-list)))
124 (and (not found) (vm-menu-popup-context-menu event)))) 128 (and (not found) (vm-menu-popup-context-menu event))))
125 ;; The XEmacs code is not actually used now, since all 129 ;; The XEmacs code is not actually used now, since all
126 ;; selectable objects are handled by an extent keymap 130 ;; selectable objects are handled by an extent keymap
127 ;; binding that points to a more specific function. But 131 ;; binding that points to a more specific function. But
128 ;; this might come in handy later if I want selectable 132 ;; this might come in handy later if I want selectable
129 ;; objects that don't have an extent attached. 133 ;; objects that don't have an extent or extent keymap
134 ;; attached.
130 ((vm-mouse-xemacs-mouse-p) 135 ((vm-mouse-xemacs-mouse-p)
131 (set-buffer (window-buffer (event-window event))) 136 (set-buffer (window-buffer (event-window event)))
132 (and (event-point event) (goto-char (event-point event))) 137 (and (event-point event) (goto-char (event-point event)))
133 (if (extent-at (point) (current-buffer) 'vm-url) 138 (let (e)
134 (vm-mouse-send-url-at-event event) 139 (cond ((extent-at (point) (current-buffer) 'vm-url)
135 (vm-menu-popup-context-menu event))))) 140 (vm-mouse-send-url-at-event event))
141 ((setq e (extent-at (point) nil 'vm-mime-function))
142 (funcall (extent-property e 'vm-mime-function) e))
143 (t (vm-menu-popup-context-menu event)))))))
136 144
137 (defun vm-mouse-send-url-at-event (event) 145 (defun vm-mouse-send-url-at-event (event)
138 (interactive "e") 146 (interactive "e")
139 (cond ((vm-mouse-xemacs-mouse-p) 147 (cond ((vm-mouse-xemacs-mouse-p)
140 (set-buffer (window-buffer (event-window event))) 148 (set-buffer (window-buffer (event-window event)))
144 (set-buffer (window-buffer (posn-window (event-start event)))) 152 (set-buffer (window-buffer (posn-window (event-start event))))
145 (goto-char (posn-point (event-start event))) 153 (goto-char (posn-point (event-start event)))
146 (vm-mouse-send-url-at-position (posn-point (event-start event)))))) 154 (vm-mouse-send-url-at-position (posn-point (event-start event))))))
147 155
148 (defun vm-mouse-send-url-at-position (pos &optional browser) 156 (defun vm-mouse-send-url-at-position (pos &optional browser)
149 (cond ((vm-mouse-xemacs-mouse-p) 157 (save-restriction
150 (let ((e (extent-at pos (current-buffer) 'vm-url)) 158 (widen)
151 url) 159 (cond ((vm-mouse-xemacs-mouse-p)
152 (if (null e) 160 (let ((e (extent-at pos (current-buffer) 'vm-url))
153 nil 161 url)
154 (setq url (buffer-substring (extent-start-position e) 162 (if (null e)
155 (extent-end-position e))) 163 nil
156 (vm-mouse-send-url url browser)))) 164 (setq url (buffer-substring (extent-start-position e)
157 ((vm-mouse-fsfemacs-mouse-p) 165 (extent-end-position e)))
158 (let (o-list url o) 166 (vm-mouse-send-url url browser))))
159 (setq o-list (overlays-at pos)) 167 ((vm-mouse-fsfemacs-mouse-p)
160 (while (and o-list (null (overlay-get (car o-list) 'vm-url))) 168 (let (o-list url o)
161 (setq o-list (cdr o-list))) 169 (setq o-list (overlays-at pos))
162 (if (null o-list) 170 (while (and o-list (null (overlay-get (car o-list) 'vm-url)))
163 nil 171 (setq o-list (cdr o-list)))
164 (setq o (car o-list)) 172 (if (null o-list)
165 (setq url (vm-buffer-substring-no-properties 173 nil
166 (overlay-start o) 174 (setq o (car o-list))
167 (overlay-end o))) 175 (setq url (vm-buffer-substring-no-properties
168 (vm-mouse-send-url url browser)))))) 176 (overlay-start o)
177 (overlay-end o)))
178 (vm-mouse-send-url url browser)))))))
169 179
170 (defun vm-mouse-send-url (url &optional browser) 180 (defun vm-mouse-send-url (url &optional browser)
171 (let ((browser (or browser vm-url-browser))) 181 (if (string-match "^mailto:" url)
172 (cond ((symbolp browser) 182 (vm-mail-to-mailto-url url)
173 (funcall browser url)) 183 (let ((browser (or browser vm-url-browser)))
174 ((stringp browser) 184 (cond ((symbolp browser)
175 (vm-unsaved-message "Sending URL to %s..." browser) 185 (funcall browser url))
176 (vm-run-background-command browser url) 186 ((stringp browser)
177 (vm-unsaved-message "Sending URL to %s... done" browser))))) 187 (vm-unsaved-message "Sending URL to %s..." browser)
188 (vm-run-background-command browser url)
189 (vm-unsaved-message "Sending URL to %s... done" browser))))))
178 190
179 (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) 191 (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window)
180 (vm-unsaved-message "Sending URL to Netscape...") 192 (vm-unsaved-message "Sending URL to Netscape...")
181 (if new-netscape 193 (if new-netscape
182 (vm-run-background-command vm-netscape-program url) 194 (vm-run-background-command vm-netscape-program url)
219 (if (null (lookup-key vm-mode-map 'button2)) 231 (if (null (lookup-key vm-mode-map 'button2))
220 (define-key vm-mode-map 'button2 'vm-mouse-button-2))) 232 (define-key vm-mode-map 'button2 'vm-mouse-button-2)))
221 ((vm-mouse-fsfemacs-mouse-p) 233 ((vm-mouse-fsfemacs-mouse-p)
222 (if (null (lookup-key vm-mode-map [mouse-2])) 234 (if (null (lookup-key vm-mode-map [mouse-2]))
223 (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) 235 (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2))
224 (if (null (lookup-key vm-mode-map [down-mouse-3])) 236 (if vm-popup-menu-on-mouse-3
225 (progn 237 (progn
226 (define-key vm-mode-map [mouse-3] 'ignore) 238 (define-key vm-mode-map [mouse-3] 'ignore)
227 (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) 239 (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3))))))
228 240
229 (defun vm-run-background-command (command &rest arg-list) 241 (defun vm-run-background-command (command &rest arg-list)
230 (apply (function call-process) command nil 0 nil arg-list)) 242 (apply (function call-process) command nil 0 nil arg-list))
231 243
232 (defun vm-run-command (command &rest arg-list) 244 (defun vm-run-command (command &rest arg-list)
233 (apply (function call-process) command nil nil nil arg-list)) 245 (apply (function call-process) command nil nil nil arg-list))
246
247 ;; return t on zero exit status
248 ;; return (exit-status . stderr-string) on nonzero exit status
249 (defun vm-run-command-on-region (start end output-buffer command
250 &rest arg-list)
251 (let ((tempfile nil) status errstring)
252 (unwind-protect
253 (progn
254 (setq tempfile (vm-make-tempfile-name))
255 (setq status
256 (apply 'call-process-region
257 start end command nil
258 (list output-buffer tempfile)
259 nil arg-list))
260 (cond ((equal status 0) t)
261 ((zerop (save-excursion
262 (set-buffer (find-file-noselect tempfile))
263 (buffer-size)))
264 t)
265 (t (save-excursion
266 (set-buffer (find-file-noselect tempfile))
267 (setq errstring (buffer-string))
268 (kill-buffer nil)
269 (cons status errstring)))))
270 (vm-error-free-call 'delete-file tempfile))))
234 271
235 ;; stupid yammering compiler 272 ;; stupid yammering compiler
236 (defvar vm-mouse-read-file-name-prompt) 273 (defvar vm-mouse-read-file-name-prompt)
237 (defvar vm-mouse-read-file-name-dir) 274 (defvar vm-mouse-read-file-name-dir)
238 (defvar vm-mouse-read-file-name-default) 275 (defvar vm-mouse-read-file-name-default)
264 (setq vm-mouse-read-file-name-must-match must-match) 301 (setq vm-mouse-read-file-name-must-match must-match)
265 (setq vm-mouse-read-file-name-initial initial) 302 (setq vm-mouse-read-file-name-initial initial)
266 (setq vm-mouse-read-file-name-history history) 303 (setq vm-mouse-read-file-name-history history)
267 (setq vm-mouse-read-file-name-prompt prompt) 304 (setq vm-mouse-read-file-name-prompt prompt)
268 (setq vm-mouse-read-file-name-return-value nil) 305 (setq vm-mouse-read-file-name-return-value nil)
269 (save-excursion 306 (if (and vm-frame-per-completion (vm-multiple-frames-possible-p))
270 (vm-goto-new-frame 'completion)) 307 (save-excursion
308 (vm-goto-new-frame 'completion)))
271 (switch-to-buffer (current-buffer)) 309 (switch-to-buffer (current-buffer))
272 (vm-mouse-read-file-name-event-handler) 310 (vm-mouse-read-file-name-event-handler)
273 (save-excursion 311 (save-excursion
274 (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler) 312 (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler)
275 (recursive-edit)) 313 (recursive-edit))
319 (setq start (point)) 357 (setq start (point))
320 (insert key-doc) 358 (insert key-doc)
321 (vm-mouse-set-mouse-track-highlight start (point)) 359 (vm-mouse-set-mouse-track-highlight start (point))
322 (vm-set-region-face start (point) 'italic) 360 (vm-set-region-face start (point) 'italic)
323 (insert ?\n ?\n) 361 (insert ?\n ?\n)
324 (setq list (directory-files default-directory)) 362 (setq list (vm-delete-backup-file-names
363 (vm-delete-auto-save-file-names
364 (directory-files default-directory))))
325 (vm-show-list list 'vm-mouse-read-file-name-event-handler) 365 (vm-show-list list 'vm-mouse-read-file-name-event-handler)
326 (setq buffer-read-only t))) 366 (setq buffer-read-only t)))
327 367
328 (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit) 368 (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit)
329 (interactive) 369 (interactive)
349 (make-local-variable 'vm-mouse-read-string-return-value) 389 (make-local-variable 'vm-mouse-read-string-return-value)
350 (setq vm-mouse-read-string-prompt prompt) 390 (setq vm-mouse-read-string-prompt prompt)
351 (setq vm-mouse-read-string-completion-list completion-list) 391 (setq vm-mouse-read-string-completion-list completion-list)
352 (setq vm-mouse-read-string-multi-word multi-word) 392 (setq vm-mouse-read-string-multi-word multi-word)
353 (setq vm-mouse-read-string-return-value nil) 393 (setq vm-mouse-read-string-return-value nil)
354 (save-excursion 394 (if (and vm-frame-per-completion (vm-multiple-frames-possible-p))
355 (vm-goto-new-frame 'completion)) 395 (save-excursion
396 (vm-goto-new-frame 'completion)))
356 (switch-to-buffer (current-buffer)) 397 (switch-to-buffer (current-buffer))
357 (vm-mouse-read-string-event-handler) 398 (vm-mouse-read-string-event-handler)
358 (save-excursion 399 (save-excursion
359 (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler) 400 (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler)
360 (recursive-edit)) 401 (recursive-edit))
367 (kill-buffer (current-buffer)))))) 408 (kill-buffer (current-buffer))))))
368 409
369 (defun vm-mouse-read-string-event-handler (&optional string) 410 (defun vm-mouse-read-string-event-handler (&optional string)
370 (let ((key-doc "Click here for keyboard interface.") 411 (let ((key-doc "Click here for keyboard interface.")
371 (bs-doc " .... to go back one word.") 412 (bs-doc " .... to go back one word.")
372 (done-doc " .... to when you're done.") 413 (done-doc " .... when you're done.")
373 start list) 414 start list)
374 (if string 415 (if string
375 (cond ((equal string key-doc) 416 (cond ((equal string key-doc)
376 (condition-case nil 417 (condition-case nil
377 (save-excursion 418 (save-excursion