cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-mouse.el

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