| 1 : |
steve |
1.1 |
;;; Mouse related functions and commands |
| 2 : |
|
|
;;; Copyright (C) 1995-1997 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 : |
youngs |
1.10 |
;;(provide 'vm-mouse) |
| 19 : |
steve |
1.1 |
|
| 20 : |
steveb |
1.3 |
(defun vm-mouse-set-mouse-track-highlight (start end &optional overlay) |
| 21 : |
|
|
(if (null overlay) |
| 22 : |
|
|
(cond (vm-fsfemacs-p |
| 23 : |
|
|
(let ((o (make-overlay start end))) |
| 24 : |
|
|
(overlay-put o 'mouse-face 'highlight) |
| 25 : |
|
|
o )) |
| 26 : |
|
|
(vm-xemacs-p |
| 27 : |
|
|
(let ((o (make-extent start end))) |
| 28 : |
|
|
(set-extent-property o 'start-open t) |
| 29 : |
|
|
(set-extent-property o 'priority 10) |
| 30 : |
|
|
(set-extent-property o 'highlight t) |
| 31 : |
|
|
o ))) |
| 32 : |
|
|
(cond (vm-fsfemacs-p |
| 33 : |
|
|
(move-overlay overlay start end)) |
| 34 : |
|
|
(vm-xemacs-p |
| 35 : |
|
|
(set-extent-endpoints overlay start end))))) |
| 36 : |
steve |
1.1 |
|
| 37 : |
|
|
(defun vm-mouse-button-2 (event) |
| 38 : |
|
|
(interactive "e") |
| 39 : |
|
|
;; go to where the event occurred |
| 40 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 41 : |
|
|
(set-buffer (window-buffer (event-window event))) |
| 42 : |
|
|
(and (event-point event) (goto-char (event-point event)))) |
| 43 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 44 : |
|
|
(set-buffer (window-buffer (posn-window (event-start event)))) |
| 45 : |
|
|
(goto-char (posn-point (event-start event))))) |
| 46 : |
|
|
;; now dispatch depending on where we are |
| 47 : |
|
|
(cond ((eq major-mode 'vm-summary-mode) |
| 48 : |
|
|
(mouse-set-point event) |
| 49 : |
|
|
(beginning-of-line) |
| 50 : |
|
|
(if (let ((vm-follow-summary-cursor t)) |
| 51 : |
|
|
(vm-follow-summary-cursor)) |
| 52 : |
|
|
nil |
| 53 : |
|
|
(setq this-command 'vm-scroll-forward) |
| 54 : |
|
|
(call-interactively 'vm-scroll-forward))) |
| 55 : |
youngs |
1.7 |
((eq major-mode 'vm-folders-summary-mode) |
| 56 : |
|
|
(mouse-set-point event) |
| 57 : |
|
|
(beginning-of-line) |
| 58 : |
|
|
(vm-follow-folders-summary-cursor)) |
| 59 : |
steve |
1.1 |
((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode)) |
| 60 : |
|
|
(vm-mouse-popup-or-select event)))) |
| 61 : |
|
|
|
| 62 : |
|
|
(defun vm-mouse-button-3 (event) |
| 63 : |
|
|
(interactive "e") |
| 64 : |
|
|
(if vm-use-menus |
| 65 : |
|
|
(progn |
| 66 : |
|
|
;; go to where the event occurred |
| 67 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 68 : |
|
|
(set-buffer (window-buffer (event-window event))) |
| 69 : |
|
|
(and (event-point event) (goto-char (event-point event)))) |
| 70 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 71 : |
|
|
(set-buffer (window-buffer (posn-window (event-start event)))) |
| 72 : |
|
|
(goto-char (posn-point (event-start event))))) |
| 73 : |
|
|
;; now dispatch depending on where we are |
| 74 : |
|
|
(cond ((eq major-mode 'vm-summary-mode) |
| 75 : |
|
|
(vm-menu-popup-mode-menu event)) |
| 76 : |
|
|
((eq major-mode 'vm-mode) |
| 77 : |
|
|
(vm-menu-popup-context-menu event)) |
| 78 : |
|
|
((eq major-mode 'vm-presentation-mode) |
| 79 : |
|
|
(vm-menu-popup-context-menu event)) |
| 80 : |
|
|
((eq major-mode 'vm-virtual-mode) |
| 81 : |
|
|
(vm-menu-popup-context-menu event)) |
| 82 : |
|
|
((eq major-mode 'mail-mode) |
| 83 : |
|
|
(vm-menu-popup-context-menu event)))))) |
| 84 : |
|
|
|
| 85 : |
|
|
(defun vm-mouse-3-help (object) |
| 86 : |
|
|
nil |
| 87 : |
|
|
"Use mouse button 3 to see a menu of options.") |
| 88 : |
|
|
|
| 89 : |
|
|
(defun vm-mouse-get-mouse-track-string (event) |
| 90 : |
|
|
(save-excursion |
| 91 : |
|
|
;; go to where the event occurred |
| 92 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 93 : |
|
|
(set-buffer (window-buffer (event-window event))) |
| 94 : |
|
|
(and (event-point event) (goto-char (event-point event)))) |
| 95 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 96 : |
|
|
(set-buffer (window-buffer (posn-window (event-start event)))) |
| 97 : |
|
|
(goto-char (posn-point (event-start event))))) |
| 98 : |
steveb |
1.2 |
(cond (vm-fsfemacs-p |
| 99 : |
steve |
1.1 |
(let ((o-list (overlays-at (point))) |
| 100 : |
|
|
(string nil)) |
| 101 : |
|
|
(while o-list |
| 102 : |
|
|
(if (overlay-get (car o-list) 'mouse-face) |
| 103 : |
|
|
(setq string (vm-buffer-substring-no-properties |
| 104 : |
|
|
(overlay-start (car o-list)) |
| 105 : |
|
|
(overlay-end (car o-list))) |
| 106 : |
|
|
o-list nil) |
| 107 : |
|
|
(setq o-list (cdr o-list)))) |
| 108 : |
|
|
string )) |
| 109 : |
|
|
(vm-xemacs-p |
| 110 : |
|
|
(let ((e (extent-at (point) nil 'highlight))) |
| 111 : |
|
|
(if e |
| 112 : |
|
|
(buffer-substring (extent-start-position e) |
| 113 : |
|
|
(extent-end-position e)) |
| 114 : |
|
|
nil))) |
| 115 : |
|
|
(t nil)))) |
| 116 : |
|
|
|
| 117 : |
|
|
(defun vm-mouse-popup-or-select (event) |
| 118 : |
|
|
(interactive "e") |
| 119 : |
|
|
(cond ((vm-mouse-fsfemacs-mouse-p) |
| 120 : |
|
|
(set-buffer (window-buffer (posn-window (event-start event)))) |
| 121 : |
|
|
(goto-char (posn-point (event-start event))) |
| 122 : |
|
|
(let (o-list (found nil)) |
| 123 : |
|
|
(setq o-list (overlays-at (point))) |
| 124 : |
|
|
(while (and o-list (not found)) |
| 125 : |
|
|
(cond ((overlay-get (car o-list) 'vm-url) |
| 126 : |
|
|
(setq found t) |
| 127 : |
|
|
(vm-mouse-send-url-at-event event)) |
| 128 : |
|
|
((overlay-get (car o-list) 'vm-mime-function) |
| 129 : |
|
|
(setq found t) |
| 130 : |
|
|
(funcall (overlay-get (car o-list) 'vm-mime-function) |
| 131 : |
|
|
(car o-list)))) |
| 132 : |
|
|
(setq o-list (cdr o-list))) |
| 133 : |
|
|
(and (not found) (vm-menu-popup-context-menu event)))) |
| 134 : |
|
|
;; The XEmacs code is not actually used now, since all |
| 135 : |
|
|
;; selectable objects are handled by an extent keymap |
| 136 : |
|
|
;; binding that points to a more specific function. But |
| 137 : |
|
|
;; this might come in handy later if I want selectable |
| 138 : |
steveb |
1.6 |
;; objects that don't have an extent keymap attached. |
| 139 : |
steve |
1.1 |
((vm-mouse-xemacs-mouse-p) |
| 140 : |
|
|
(set-buffer (window-buffer (event-window event))) |
| 141 : |
|
|
(and (event-point event) (goto-char (event-point event))) |
| 142 : |
|
|
(let (e) |
| 143 : |
|
|
(cond ((extent-at (point) (current-buffer) 'vm-url) |
| 144 : |
|
|
(vm-mouse-send-url-at-event event)) |
| 145 : |
|
|
((setq e (extent-at (point) nil 'vm-mime-function)) |
| 146 : |
|
|
(funcall (extent-property e 'vm-mime-function) e)) |
| 147 : |
|
|
(t (vm-menu-popup-context-menu event))))))) |
| 148 : |
|
|
|
| 149 : |
|
|
(defun vm-mouse-send-url-at-event (event) |
| 150 : |
|
|
(interactive "e") |
| 151 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 152 : |
|
|
(set-buffer (window-buffer (event-window event))) |
| 153 : |
|
|
(and (event-point event) (goto-char (event-point event))) |
| 154 : |
|
|
(vm-mouse-send-url-at-position (event-point event))) |
| 155 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 156 : |
|
|
(set-buffer (window-buffer (posn-window (event-start event)))) |
| 157 : |
|
|
(goto-char (posn-point (event-start event))) |
| 158 : |
|
|
(vm-mouse-send-url-at-position (posn-point (event-start event)))))) |
| 159 : |
|
|
|
| 160 : |
|
|
(defun vm-mouse-send-url-at-position (pos &optional browser) |
| 161 : |
|
|
(save-restriction |
| 162 : |
|
|
(widen) |
| 163 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 164 : |
|
|
(let ((e (extent-at pos (current-buffer) 'vm-url)) |
| 165 : |
|
|
url) |
| 166 : |
|
|
(if (null e) |
| 167 : |
|
|
nil |
| 168 : |
|
|
(setq url (buffer-substring (extent-start-position e) |
| 169 : |
|
|
(extent-end-position e))) |
| 170 : |
|
|
(vm-mouse-send-url url browser)))) |
| 171 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 172 : |
|
|
(let (o-list url o) |
| 173 : |
|
|
(setq o-list (overlays-at pos)) |
| 174 : |
|
|
(while (and o-list (null (overlay-get (car o-list) 'vm-url))) |
| 175 : |
|
|
(setq o-list (cdr o-list))) |
| 176 : |
|
|
(if (null o-list) |
| 177 : |
|
|
nil |
| 178 : |
|
|
(setq o (car o-list)) |
| 179 : |
|
|
(setq url (vm-buffer-substring-no-properties |
| 180 : |
|
|
(overlay-start o) |
| 181 : |
|
|
(overlay-end o))) |
| 182 : |
|
|
(vm-mouse-send-url url browser))))))) |
| 183 : |
|
|
|
| 184 : |
youngs |
1.9 |
(defun vm-mouse-send-url (url &optional browser switches) |
| 185 : |
steve |
1.1 |
(if (string-match "^mailto:" url) |
| 186 : |
|
|
(vm-mail-to-mailto-url url) |
| 187 : |
youngs |
1.9 |
(let ((browser (or browser vm-url-browser)) |
| 188 : |
|
|
(switches (or switches vm-url-browser-switches))) |
| 189 : |
steve |
1.1 |
(cond ((symbolp browser) |
| 190 : |
|
|
(funcall browser url)) |
| 191 : |
|
|
((stringp browser) |
| 192 : |
|
|
(message "Sending URL to %s..." browser) |
| 193 : |
youngs |
1.9 |
(apply 'vm-run-background-command browser |
| 194 : |
|
|
(append switches (list url))) |
| 195 : |
steve |
1.1 |
(message "Sending URL to %s... done" browser)))))) |
| 196 : |
|
|
|
| 197 : |
|
|
(defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) |
| 198 : |
steveb |
1.4 |
;; Change commas to %2C to avoid confusing Netscape -remote. |
| 199 : |
|
|
(while (string-match "," url) |
| 200 : |
|
|
(setq url (replace-match "%2C" nil t url))) |
| 201 : |
steve |
1.1 |
(message "Sending URL to Netscape...") |
| 202 : |
|
|
(if new-netscape |
| 203 : |
|
|
(apply 'vm-run-background-command vm-netscape-program |
| 204 : |
|
|
(append vm-netscape-program-switches (list url))) |
| 205 : |
steveb |
1.6 |
(or (equal 0 (apply 'vm-run-command vm-netscape-program |
| 206 : |
|
|
(append vm-netscape-program-switches |
| 207 : |
|
|
(list "-remote" |
| 208 : |
|
|
(concat "openURL(" url |
| 209 : |
steveb |
1.5 |
(if new-window ",new-window" "") |
| 210 : |
steveb |
1.6 |
")"))))) |
| 211 : |
steve |
1.1 |
(vm-mouse-send-url-to-netscape url t new-window))) |
| 212 : |
|
|
(message "Sending URL to Netscape... done")) |
| 213 : |
|
|
|
| 214 : |
|
|
(defun vm-mouse-send-url-to-netscape-new-window (url) |
| 215 : |
|
|
(vm-mouse-send-url-to-netscape url nil t)) |
| 216 : |
steveb |
1.4 |
|
| 217 : |
|
|
(defvar buffer-file-type) |
| 218 : |
steve |
1.1 |
|
| 219 : |
|
|
(defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window) |
| 220 : |
youngs |
1.8 |
(vm-mouse-send-url-to-xxxx-mosaic 'mosaic url new-mosaic new-window)) |
| 221 : |
|
|
|
| 222 : |
|
|
(defun vm-mouse-send-url-to-mmosaic (url &optional new-mosaic new-window) |
| 223 : |
|
|
(vm-mouse-send-url-to-xxxx-mosaic 'mmosaic url new-mosaic new-window)) |
| 224 : |
|
|
|
| 225 : |
|
|
(defun vm-mouse-send-url-to-xxxx-mosaic (m-type url &optional |
| 226 : |
|
|
new-mosaic new-window) |
| 227 : |
|
|
(let ((what (cond ((eq m-type 'mmosaic) "mMosaic") |
| 228 : |
|
|
(t "Mosaic")))) |
| 229 : |
|
|
(message "Sending URL to %s..." what) |
| 230 : |
|
|
(if (null new-mosaic) |
| 231 : |
|
|
(let ((pid-file (cond ((eq m-type 'mmosaic) |
| 232 : |
|
|
"~/.mMosaic/.mosaicpid") |
| 233 : |
|
|
(t "~/.mosaicpid"))) |
| 234 : |
|
|
(work-buffer " *mosaic work*") |
| 235 : |
|
|
(coding-system-for-read (vm-line-ending-coding-system)) |
| 236 : |
|
|
(coding-system-for-write (vm-line-ending-coding-system)) |
| 237 : |
|
|
pid) |
| 238 : |
|
|
(cond ((file-exists-p pid-file) |
| 239 : |
|
|
(set-buffer (get-buffer-create work-buffer)) |
| 240 : |
|
|
(setq selective-display nil) |
| 241 : |
|
|
(erase-buffer) |
| 242 : |
|
|
(insert-file-contents pid-file) |
| 243 : |
|
|
(setq pid (int-to-string (string-to-int (buffer-string)))) |
| 244 : |
|
|
(erase-buffer) |
| 245 : |
|
|
(insert (if new-window "newwin" "goto") ?\n) |
| 246 : |
|
|
(insert url ?\n) |
| 247 : |
|
|
;; newline convention used should be the local |
| 248 : |
|
|
;; one, whatever that is. |
| 249 : |
|
|
(setq buffer-file-type nil) |
| 250 : |
|
|
(if (fboundp 'set-buffer-file-coding-system) |
| 251 : |
|
|
(set-buffer-file-coding-system |
| 252 : |
|
|
(vm-line-ending-coding-system) nil)) |
| 253 : |
|
|
(write-region (point-min) (point-max) |
| 254 : |
|
|
(concat "/tmp/Mosaic." pid) |
| 255 : |
|
|
nil 0) |
| 256 : |
|
|
(set-buffer-modified-p nil) |
| 257 : |
|
|
(kill-buffer work-buffer))) |
| 258 : |
|
|
(cond ((or (null pid) |
| 259 : |
|
|
(not (equal 0 (vm-run-command "kill" "-USR1" pid)))) |
| 260 : |
|
|
(setq new-mosaic t))))) |
| 261 : |
|
|
(if new-mosaic |
| 262 : |
|
|
(apply 'vm-run-background-command |
| 263 : |
|
|
(cond ((eq m-type 'mmosaic) vm-mmosaic-program) |
| 264 : |
|
|
(t vm-mosaic-program)) |
| 265 : |
|
|
(append (cond ((eq m-type 'mmosaic) vm-mmosaic-program-switches) |
| 266 : |
|
|
(t vm-mosaic-program-switches)) |
| 267 : |
|
|
(list url)))) |
| 268 : |
|
|
(message "Sending URL to %s... done" what))) |
| 269 : |
steve |
1.1 |
|
| 270 : |
|
|
(defun vm-mouse-send-url-to-mosaic-new-window (url) |
| 271 : |
|
|
(vm-mouse-send-url-to-mosaic url nil t)) |
| 272 : |
youngs |
1.9 |
|
| 273 : |
|
|
(defun vm-mouse-send-url-to-konqueror (url &optional new-konqueror) |
| 274 : |
|
|
(message "Sending URL to Konqueror...") |
| 275 : |
|
|
(if new-konqueror |
| 276 : |
|
|
(apply 'vm-run-background-command vm-konqueror-program |
| 277 : |
|
|
(append vm-konqueror-program-switches (list url))) |
| 278 : |
|
|
(or (equal 0 (apply 'vm-run-command vm-konqueror-client-program |
| 279 : |
|
|
(append vm-konqueror-client-program-switches |
| 280 : |
|
|
(list "openURL" url)))) |
| 281 : |
|
|
(vm-mouse-send-url-to-konqueror url t))) |
| 282 : |
|
|
(message "Sending URL to Konqueror... done")) |
| 283 : |
|
|
|
| 284 : |
|
|
(defun vm-mouse-send-url-to-konqueror-new-browser (url) |
| 285 : |
|
|
(vm-mouse-send-url-to-konqueror url t)) |
| 286 : |
|
|
|
| 287 : |
|
|
(defun vm-mouse-send-url-to-clipboard (url) |
| 288 : |
|
|
(message "Sending URL to X Clipboard...") |
| 289 : |
|
|
(cond ((fboundp 'own-selection) |
| 290 : |
|
|
(own-selection url 'CLIPBOARD)) |
| 291 : |
|
|
((fboundp 'x-own-clipboard) |
| 292 : |
|
|
(x-own-clipboard url)) |
| 293 : |
|
|
((fboundp 'x-own-selection-internal) |
| 294 : |
|
|
(x-own-selection-internal 'CLIPBOARD url))) |
| 295 : |
|
|
(message "Sending URL to X Clipboard... done")) |
| 296 : |
steve |
1.1 |
|
| 297 : |
|
|
(defun vm-mouse-install-mouse () |
| 298 : |
|
|
(cond ((vm-mouse-xemacs-mouse-p) |
| 299 : |
|
|
(if (null (lookup-key vm-mode-map 'button2)) |
| 300 : |
|
|
(define-key vm-mode-map 'button2 'vm-mouse-button-2))) |
| 301 : |
|
|
((vm-mouse-fsfemacs-mouse-p) |
| 302 : |
|
|
(if (null (lookup-key vm-mode-map [mouse-2])) |
| 303 : |
|
|
(define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) |
| 304 : |
|
|
(if vm-popup-menu-on-mouse-3 |
| 305 : |
|
|
(progn |
| 306 : |
|
|
(define-key vm-mode-map [mouse-3] 'ignore) |
| 307 : |
|
|
(define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) |
| 308 : |
|
|
|
| 309 : |
|
|
(defun vm-run-background-command (command &rest arg-list) |
| 310 : |
|
|
(apply (function call-process) command nil 0 nil arg-list)) |
| 311 : |
|
|
|
| 312 : |
|
|
(defun vm-run-command (command &rest arg-list) |
| 313 : |
|
|
(apply (function call-process) command nil nil nil arg-list)) |
| 314 : |
|
|
|
| 315 : |
|
|
;; return t on zero exit status |
| 316 : |
|
|
;; return (exit-status . stderr-string) on nonzero exit status |
| 317 : |
|
|
(defun vm-run-command-on-region (start end output-buffer command |
| 318 : |
|
|
&rest arg-list) |
| 319 : |
|
|
(let ((tempfile nil) |
| 320 : |
steveb |
1.5 |
;; use binary coding system in FSF Emacs/MULE |
| 321 : |
youngs |
1.7 |
(coding-system-for-read (vm-binary-coding-system)) |
| 322 : |
|
|
(coding-system-for-write (vm-binary-coding-system)) |
| 323 : |
steve |
1.1 |
;; for DOS/Windows command to tell it that its input is |
| 324 : |
|
|
;; binary. |
| 325 : |
|
|
(binary-process-input t) |
| 326 : |
steveb |
1.5 |
;; call-process-region calls write-region. |
| 327 : |
|
|
;; don't let it do CR -> LF translation. |
| 328 : |
|
|
(selective-display nil) |
| 329 : |
steve |
1.1 |
status errstring) |
| 330 : |
|
|
(unwind-protect |
| 331 : |
|
|
(progn |
| 332 : |
|
|
(setq tempfile (vm-make-tempfile-name)) |
| 333 : |
|
|
(setq status |
| 334 : |
|
|
(apply 'call-process-region |
| 335 : |
|
|
start end command nil |
| 336 : |
|
|
(list output-buffer tempfile) |
| 337 : |
|
|
nil arg-list)) |
| 338 : |
|
|
(cond ((equal status 0) t) |
| 339 : |
|
|
;; even if exit status non-zero, if there was no |
| 340 : |
|
|
;; diagnostic output the command probably |
| 341 : |
|
|
;; succeeded. I have tried to just use exit status |
| 342 : |
|
|
;; as the failure criterion and users complained. |
| 343 : |
|
|
((equal (nth 7 (file-attributes tempfile)) 0) |
| 344 : |
|
|
(message "%s exited non-zero (code %s)" command status) |
| 345 : |
|
|
t) |
| 346 : |
|
|
(t (save-excursion |
| 347 : |
|
|
(message "%s exited non-zero (code %s)" command status) |
| 348 : |
|
|
(set-buffer (find-file-noselect tempfile)) |
| 349 : |
|
|
(setq errstring (buffer-string)) |
| 350 : |
|
|
(kill-buffer nil) |
| 351 : |
|
|
(cons status errstring))))) |
| 352 : |
|
|
(vm-error-free-call 'delete-file tempfile)))) |
| 353 : |
|
|
|
| 354 : |
|
|
;; stupid yammering compiler |
| 355 : |
|
|
(defvar vm-mouse-read-file-name-prompt) |
| 356 : |
|
|
(defvar vm-mouse-read-file-name-dir) |
| 357 : |
|
|
(defvar vm-mouse-read-file-name-default) |
| 358 : |
|
|
(defvar vm-mouse-read-file-name-must-match) |
| 359 : |
|
|
(defvar vm-mouse-read-file-name-initial) |
| 360 : |
|
|
(defvar vm-mouse-read-file-name-history) |
| 361 : |
|
|
(defvar vm-mouse-read-file-name-return-value) |
| 362 : |
steveb |
1.2 |
(defvar vm-mouse-read-file-name-should-delete-frame) |
| 363 : |
steve |
1.1 |
|
| 364 : |
|
|
(defun vm-mouse-read-file-name (prompt &optional dir default |
| 365 : |
|
|
must-match initial history) |
| 366 : |
|
|
"Like read-file-name, except uses a mouse driven interface. |
| 367 : |
|
|
HISTORY argument is ignored." |
| 368 : |
|
|
(save-excursion |
| 369 : |
|
|
(or dir (setq dir default-directory)) |
| 370 : |
youngs |
1.7 |
(set-buffer (vm-make-work-buffer " *Files*")) |
| 371 : |
steve |
1.1 |
(use-local-map (make-sparse-keymap)) |
| 372 : |
|
|
(setq buffer-read-only t |
| 373 : |
|
|
default-directory dir) |
| 374 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-prompt) |
| 375 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-dir) |
| 376 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-default) |
| 377 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-must-match) |
| 378 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-initial) |
| 379 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-history) |
| 380 : |
|
|
(make-local-variable 'vm-mouse-read-file-name-return-value) |
| 381 : |
steveb |
1.2 |
(make-local-variable 'vm-mouse-read-file-name-should-delete-frame) |
| 382 : |
steve |
1.1 |
(setq vm-mouse-read-file-name-prompt prompt) |
| 383 : |
|
|
(setq vm-mouse-read-file-name-dir dir) |
| 384 : |
|
|
(setq vm-mouse-read-file-name-default default) |
| 385 : |
|
|
(setq vm-mouse-read-file-name-must-match must-match) |
| 386 : |
|
|
(setq vm-mouse-read-file-name-initial initial) |
| 387 : |
|
|
(setq vm-mouse-read-file-name-history history) |
| 388 : |
|
|
(setq vm-mouse-read-file-name-prompt prompt) |
| 389 : |
|
|
(setq vm-mouse-read-file-name-return-value nil) |
| 390 : |
steveb |
1.2 |
(setq vm-mouse-read-file-name-should-delete-frame nil) |
| 391 : |
steve |
1.1 |
(if (and vm-mutable-frames vm-frame-per-completion |
| 392 : |
|
|
(vm-multiple-frames-possible-p)) |
| 393 : |
|
|
(save-excursion |
| 394 : |
steveb |
1.2 |
(setq vm-mouse-read-file-name-should-delete-frame t) |
| 395 : |
steve |
1.1 |
(vm-goto-new-frame 'completion))) |
| 396 : |
|
|
(switch-to-buffer (current-buffer)) |
| 397 : |
|
|
(vm-mouse-read-file-name-event-handler) |
| 398 : |
|
|
(save-excursion |
| 399 : |
|
|
(local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler) |
| 400 : |
|
|
(recursive-edit)) |
| 401 : |
|
|
;; buffer could have been killed |
| 402 : |
|
|
(and (boundp 'vm-mouse-read-file-name-return-value) |
| 403 : |
|
|
(prog1 |
| 404 : |
|
|
vm-mouse-read-file-name-return-value |
| 405 : |
|
|
(kill-buffer (current-buffer)))))) |
| 406 : |
|
|
|
| 407 : |
|
|
(defun vm-mouse-read-file-name-event-handler (&optional string) |
| 408 : |
|
|
(let ((key-doc "Click here for keyboard interface.") |
| 409 : |
|
|
start list) |
| 410 : |
|
|
(if string |
| 411 : |
|
|
(cond ((equal string key-doc) |
| 412 : |
|
|
(condition-case nil |
| 413 : |
|
|
(save-excursion |
| 414 : |
|
|
(setq vm-mouse-read-file-name-return-value |
| 415 : |
|
|
(save-excursion |
| 416 : |
|
|
(vm-keyboard-read-file-name |
| 417 : |
|
|
vm-mouse-read-file-name-prompt |
| 418 : |
|
|
vm-mouse-read-file-name-dir |
| 419 : |
|
|
vm-mouse-read-file-name-default |
| 420 : |
|
|
vm-mouse-read-file-name-must-match |
| 421 : |
|
|
vm-mouse-read-file-name-initial |
| 422 : |
|
|
vm-mouse-read-file-name-history))) |
| 423 : |
|
|
(vm-mouse-read-file-name-quit-handler t)) |
| 424 : |
|
|
(quit (vm-mouse-read-file-name-quit-handler)))) |
| 425 : |
|
|
((file-directory-p string) |
| 426 : |
|
|
(setq default-directory (expand-file-name string))) |
| 427 : |
|
|
(t (setq vm-mouse-read-file-name-return-value |
| 428 : |
|
|
(expand-file-name string)) |
| 429 : |
|
|
(vm-mouse-read-file-name-quit-handler t)))) |
| 430 : |
|
|
(setq buffer-read-only nil) |
| 431 : |
|
|
(erase-buffer) |
| 432 : |
|
|
(setq start (point)) |
| 433 : |
|
|
(insert vm-mouse-read-file-name-prompt) |
| 434 : |
|
|
(vm-set-region-face start (point) 'bold) |
| 435 : |
|
|
(cond ((and (not string) vm-mouse-read-file-name-default) |
| 436 : |
|
|
(setq start (point)) |
| 437 : |
|
|
(insert vm-mouse-read-file-name-default) |
| 438 : |
|
|
(vm-mouse-set-mouse-track-highlight start (point))) |
| 439 : |
|
|
((not string) nil) |
| 440 : |
|
|
(t (insert default-directory))) |
| 441 : |
|
|
(insert ?\n ?\n) |
| 442 : |
|
|
(setq start (point)) |
| 443 : |
|
|
(insert key-doc) |
| 444 : |
|
|
(vm-mouse-set-mouse-track-highlight start (point)) |
| 445 : |
|
|
(vm-set-region-face start (point) 'italic) |
| 446 : |
|
|
(insert ?\n ?\n) |
| 447 : |
|
|
(setq list (vm-delete-backup-file-names |
| 448 : |
|
|
(vm-delete-auto-save-file-names |
| 449 : |
steveb |
1.2 |
(vm-delete-index-file-names |
| 450 : |
|
|
(directory-files default-directory))))) |
| 451 : |
steve |
1.1 |
(vm-show-list list 'vm-mouse-read-file-name-event-handler) |
| 452 : |
|
|
(setq buffer-read-only t))) |
| 453 : |
|
|
|
| 454 : |
|
|
(defun vm-mouse-read-file-name-quit-handler (&optional normal-exit) |
| 455 : |
|
|
(interactive) |
| 456 : |
steveb |
1.2 |
(if vm-mouse-read-file-name-should-delete-frame |
| 457 : |
|
|
(vm-maybe-delete-windows-or-frames-on (current-buffer))) |
| 458 : |
steve |
1.1 |
(if normal-exit |
| 459 : |
|
|
(throw 'exit nil) |
| 460 : |
|
|
(throw 'exit t))) |
| 461 : |
|
|
|
| 462 : |
|
|
(defvar vm-mouse-read-string-prompt) |
| 463 : |
|
|
(defvar vm-mouse-read-string-completion-list) |
| 464 : |
|
|
(defvar vm-mouse-read-string-multi-word) |
| 465 : |
|
|
(defvar vm-mouse-read-string-return-value) |
| 466 : |
steveb |
1.2 |
(defvar vm-mouse-read-string-should-delete-frame) |
| 467 : |
steve |
1.1 |
|
| 468 : |
|
|
(defun vm-mouse-read-string (prompt completion-list &optional multi-word) |
| 469 : |
|
|
(save-excursion |
| 470 : |
youngs |
1.7 |
(set-buffer (vm-make-work-buffer " *Choices*")) |
| 471 : |
steve |
1.1 |
(use-local-map (make-sparse-keymap)) |
| 472 : |
|
|
(setq buffer-read-only t) |
| 473 : |
|
|
(make-local-variable 'vm-mouse-read-string-prompt) |
| 474 : |
|
|
(make-local-variable 'vm-mouse-read-string-completion-list) |
| 475 : |
|
|
(make-local-variable 'vm-mouse-read-string-multi-word) |
| 476 : |
|
|
(make-local-variable 'vm-mouse-read-string-return-value) |
| 477 : |
steveb |
1.2 |
(make-local-variable 'vm-mouse-read-string-should-delete-frame) |
| 478 : |
steve |
1.1 |
(setq vm-mouse-read-string-prompt prompt) |
| 479 : |
|
|
(setq vm-mouse-read-string-completion-list completion-list) |
| 480 : |
|
|
(setq vm-mouse-read-string-multi-word multi-word) |
| 481 : |
|
|
(setq vm-mouse-read-string-return-value nil) |
| 482 : |
steveb |
1.2 |
(setq vm-mouse-read-string-should-delete-frame nil) |
| 483 : |
steve |
1.1 |
(if (and vm-mutable-frames vm-frame-per-completion |
| 484 : |
|
|
(vm-multiple-frames-possible-p)) |
| 485 : |
|
|
(save-excursion |
| 486 : |
steveb |
1.2 |
(setq vm-mouse-read-string-should-delete-frame t) |
| 487 : |
steve |
1.1 |
(vm-goto-new-frame 'completion))) |
| 488 : |
|
|
(switch-to-buffer (current-buffer)) |
| 489 : |
|
|
(vm-mouse-read-string-event-handler) |
| 490 : |
|
|
(save-excursion |
| 491 : |
|
|
(local-set-key "\C-g" 'vm-mouse-read-string-quit-handler) |
| 492 : |
|
|
(recursive-edit)) |
| 493 : |
|
|
;; buffer could have been killed |
| 494 : |
|
|
(and (boundp 'vm-mouse-read-string-return-value) |
| 495 : |
|
|
(prog1 |
| 496 : |
|
|
(if (listp vm-mouse-read-string-return-value) |
| 497 : |
|
|
(mapconcat 'identity vm-mouse-read-string-return-value " ") |
| 498 : |
|
|
vm-mouse-read-string-return-value) |
| 499 : |
|
|
(kill-buffer (current-buffer)))))) |
| 500 : |
|
|
|
| 501 : |
|
|
(defun vm-mouse-read-string-event-handler (&optional string) |
| 502 : |
|
|
(let ((key-doc "Click here for keyboard interface.") |
| 503 : |
|
|
(bs-doc " .... to go back one word.") |
| 504 : |
|
|
(done-doc " .... when you're done.") |
| 505 : |
|
|
start list) |
| 506 : |
|
|
(if string |
| 507 : |
|
|
(cond ((equal string key-doc) |
| 508 : |
|
|
(condition-case nil |
| 509 : |
|
|
(save-excursion |
| 510 : |
|
|
(setq vm-mouse-read-string-return-value |
| 511 : |
|
|
(vm-keyboard-read-string |
| 512 : |
|
|
vm-mouse-read-string-prompt |
| 513 : |
|
|
vm-mouse-read-string-completion-list |
| 514 : |
|
|
vm-mouse-read-string-multi-word)) |
| 515 : |
|
|
(vm-mouse-read-string-quit-handler t)) |
| 516 : |
|
|
(quit (vm-mouse-read-string-quit-handler)))) |
| 517 : |
|
|
((equal string bs-doc) |
| 518 : |
|
|
(setq vm-mouse-read-string-return-value |
| 519 : |
|
|
(nreverse |
| 520 : |
|
|
(cdr |
| 521 : |
|
|
(nreverse vm-mouse-read-string-return-value))))) |
| 522 : |
|
|
((equal string done-doc) |
| 523 : |
|
|
(vm-mouse-read-string-quit-handler t)) |
| 524 : |
|
|
(t (setq vm-mouse-read-string-return-value |
| 525 : |
|
|
(nconc vm-mouse-read-string-return-value |
| 526 : |
|
|
(list string))) |
| 527 : |
|
|
(if (null vm-mouse-read-string-multi-word) |
| 528 : |
|
|
(vm-mouse-read-string-quit-handler t))))) |
| 529 : |
|
|
(setq buffer-read-only nil) |
| 530 : |
|
|
(erase-buffer) |
| 531 : |
|
|
(setq start (point)) |
| 532 : |
|
|
(insert vm-mouse-read-string-prompt) |
| 533 : |
|
|
(vm-set-region-face start (point) 'bold) |
| 534 : |
|
|
(insert (mapconcat 'identity vm-mouse-read-string-return-value " ")) |
| 535 : |
|
|
(insert ?\n ?\n) |
| 536 : |
|
|
(setq start (point)) |
| 537 : |
|
|
(insert key-doc) |
| 538 : |
|
|
(vm-mouse-set-mouse-track-highlight start (point)) |
| 539 : |
|
|
(vm-set-region-face start (point) 'italic) |
| 540 : |
|
|
(insert ?\n) |
| 541 : |
|
|
(if vm-mouse-read-string-multi-word |
| 542 : |
|
|
(progn |
| 543 : |
|
|
(setq start (point)) |
| 544 : |
|
|
(insert bs-doc) |
| 545 : |
|
|
(vm-mouse-set-mouse-track-highlight start (point)) |
| 546 : |
|
|
(vm-set-region-face start (point) 'italic) |
| 547 : |
|
|
(insert ?\n) |
| 548 : |
|
|
(setq start (point)) |
| 549 : |
|
|
(insert done-doc) |
| 550 : |
|
|
(vm-mouse-set-mouse-track-highlight start (point)) |
| 551 : |
|
|
(vm-set-region-face start (point) 'italic) |
| 552 : |
|
|
(insert ?\n))) |
| 553 : |
|
|
(insert ?\n) |
| 554 : |
|
|
(vm-show-list vm-mouse-read-string-completion-list |
| 555 : |
|
|
'vm-mouse-read-string-event-handler) |
| 556 : |
|
|
(setq buffer-read-only t))) |
| 557 : |
|
|
|
| 558 : |
|
|
(defun vm-mouse-read-string-quit-handler (&optional normal-exit) |
| 559 : |
|
|
(interactive) |
| 560 : |
steveb |
1.2 |
(if vm-mouse-read-string-should-delete-frame |
| 561 : |
|
|
(vm-maybe-delete-windows-or-frames-on (current-buffer))) |
| 562 : |
steve |
1.1 |
(if normal-exit |
| 563 : |
|
|
(throw 'exit nil) |
| 564 : |
|
|
(throw 'exit t))) |
| 565 : |
youngs |
1.10 |
|
| 566 : |
|
|
(provide 'vm-mouse) |
Parent Directory
| 
Revision Log
