Mercurial > hg > xemacs-beta
diff lisp/vm/vm-mouse.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 05472e90ae02 |
children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/vm/vm-mouse.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/vm/vm-mouse.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; Mouse related functions and commands -;;; Copyright (C) 1995-1997 Kyle E. Jones +;;; Copyright (C) 1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -18,18 +18,18 @@ (provide 'vm-mouse) (defun vm-mouse-fsfemacs-mouse-p () - (and vm-fsfemacs-19-p + (and (vm-fsfemacs-19-p) (fboundp 'set-mouse-position))) (defun vm-mouse-xemacs-mouse-p () - (and vm-xemacs-p + (and (vm-xemacs-p) (fboundp 'set-mouse-position))) (defun vm-mouse-set-mouse-track-highlight (start end) - (cond (vm-fsfemacs-19-p + (cond ((fboundp 'make-overlay) (let ((o (make-overlay start end))) (overlay-put o 'mouse-face 'highlight))) - (vm-xemacs-p + ((fboundp 'make-extent) (let ((o (make-extent start end))) (set-extent-property o 'highlight t))))) @@ -48,11 +48,14 @@ (beginning-of-line) (if (let ((vm-follow-summary-cursor t)) (vm-follow-summary-cursor)) - nil + (progn + (vm-select-folder-buffer) + (vm-preview-current-message)) (setq this-command 'vm-scroll-forward) (call-interactively 'vm-scroll-forward))) - ((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode)) - (vm-mouse-popup-or-select event)))) + ((memq major-mode '(vm-mode vm-virtual-mode)) + (cond ((and (vm-mouse-fsfemacs-mouse-p) vm-url-browser) + (vm-mouse-popup-or-select event)))))) (defun vm-mouse-button-3 (event) (interactive "e") @@ -70,15 +73,12 @@ (vm-menu-popup-mode-menu event)) ((eq major-mode 'vm-mode) (vm-menu-popup-context-menu event)) - ((eq major-mode 'vm-presentation-mode) - (vm-menu-popup-context-menu event)) ((eq major-mode 'vm-virtual-mode) (vm-menu-popup-context-menu event)) ((eq major-mode 'mail-mode) - (vm-menu-popup-context-menu event)))))) + (vm-menu-popup-mode-menu event)))))) (defun vm-mouse-3-help (object) - nil "Use mouse button 3 to see a menu of options.") (defun vm-mouse-get-mouse-track-string (event) @@ -90,7 +90,7 @@ ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))))) - (cond (vm-fsfemacs-19-p + (cond ((fboundp 'overlays-at) (let ((o-list (overlays-at (point))) (string nil)) (while o-list @@ -101,7 +101,7 @@ o-list nil) (setq o-list (cdr o-list)))) string )) - (vm-xemacs-p + ((fboundp 'extent-at) (let ((e (extent-at (point) nil 'highlight))) (if e (buffer-substring (extent-start-position e) @@ -114,33 +114,25 @@ (cond ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) - (let (o-list (found nil)) + (let (o-list o menu (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (cond ((overlay-get (car o-list) 'vm-url) (setq found t) - (vm-mouse-send-url-at-event event)) - ((overlay-get (car o-list) 'vm-mime-function) - (setq found t) - (funcall (overlay-get (car o-list) 'vm-mime-function) - (car o-list)))) + (vm-mouse-send-url-at-event event))) (setq o-list (cdr o-list))) (and (not found) (vm-menu-popup-context-menu event)))) ;; The XEmacs code is not actually used now, since all ;; selectable objects are handled by an extent keymap ;; binding that points to a more specific function. But ;; this might come in handy later if I want selectable - ;; objects that don't have an extent or extent keymap - ;; attached. + ;; objects that don't have an extent attached. ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event))) - (let (e) - (cond ((extent-at (point) (current-buffer) 'vm-url) - (vm-mouse-send-url-at-event event)) - ((setq e (extent-at (point) nil 'vm-mime-function)) - (funcall (extent-property e 'vm-mime-function) e)) - (t (vm-menu-popup-context-menu event))))))) + (if (extent-at (point) (current-buffer) 'vm-url) + (vm-mouse-send-url-at-event event) + (vm-menu-popup-context-menu event))))) (defun vm-mouse-send-url-at-event (event) (interactive "e") @@ -154,58 +146,49 @@ (vm-mouse-send-url-at-position (posn-point (event-start event)))))) (defun vm-mouse-send-url-at-position (pos &optional browser) - (save-restriction - (widen) - (cond ((vm-mouse-xemacs-mouse-p) - (let ((e (extent-at pos (current-buffer) 'vm-url)) - url) - (if (null e) - nil - (setq url (buffer-substring (extent-start-position e) - (extent-end-position e))) - (vm-mouse-send-url url browser)))) - ((vm-mouse-fsfemacs-mouse-p) - (let (o-list url o) - (setq o-list (overlays-at pos)) - (while (and o-list (null (overlay-get (car o-list) 'vm-url))) - (setq o-list (cdr o-list))) - (if (null o-list) - nil - (setq o (car o-list)) - (setq url (vm-buffer-substring-no-properties - (overlay-start o) - (overlay-end o))) - (vm-mouse-send-url url browser))))))) + (cond ((vm-mouse-xemacs-mouse-p) + (let ((e (extent-at pos (current-buffer) 'vm-url)) + url) + (if (null e) + nil + (setq url (buffer-substring (extent-start-position e) + (extent-end-position e))) + (vm-mouse-send-url url browser)))) + ((vm-mouse-fsfemacs-mouse-p) + (let (o-list url o) + (setq o-list (overlays-at pos)) + (while (and o-list (null (overlay-get (car o-list) 'vm-url))) + (setq o-list (cdr o-list))) + (if (null o-list) + nil + (setq o (car o-list)) + (setq url (vm-buffer-substring-no-properties + (overlay-start o) + (overlay-end o))) + (vm-mouse-send-url url browser)))))) (defun vm-mouse-send-url (url &optional browser) - (if (string-match "^mailto:" url) - (vm-mail-to-mailto-url url) - (let ((browser (or browser vm-url-browser))) - (cond ((symbolp browser) - (funcall browser url)) - ((stringp browser) - (message "Sending URL to %s..." browser) - (vm-run-background-command browser url) - (message "Sending URL to %s... done" browser)))))) + (let ((browser (or browser vm-url-browser))) + (cond ((symbolp browser) + (funcall browser url)) + ((stringp browser) + (vm-unsaved-message "Sending URL to %s..." browser) + (vm-run-background-command browser url) + (vm-unsaved-message "Sending URL to %s... done" browser))))) (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) - (message "Sending URL to Netscape...") + (vm-unsaved-message "Sending URL to Netscape...") (if new-netscape - (apply 'vm-run-background-command vm-netscape-program - (append vm-netscape-program-switches (list url))) - (or (equal 0 (apply 'vm-run-command vm-netscape-program "-remote" - (append (list (concat "openURL(" url - (if new-window ", new-window" "") - ")")) - vm-netscape-program-switches))) + (vm-run-background-command vm-netscape-program url) + (or (equal 0 (vm-run-command vm-netscape-program "-remote" + (concat "openURL(" url + (if new-window ", new-window" "") + ")"))) (vm-mouse-send-url-to-netscape url t new-window))) - (message "Sending URL to Netscape... done")) - -(defun vm-mouse-send-url-to-netscape-new-window (url) - (vm-mouse-send-url-to-netscape url nil t)) + (vm-unsaved-message "Sending URL to Netscape... done")) (defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window) - (message "Sending URL to Mosaic...") + (vm-unsaved-message "Sending URL to Mosaic...") (if (null new-mosaic) (let ((pid-file "~/.mosaicpid") (work-buffer " *mosaic work*") @@ -218,11 +201,6 @@ (erase-buffer) (insert (if new-window "newwin" "goto") ?\n) (insert url ?\n) - ;; newline convention used should be the local - ;; one, whatever that is. - (setq buffer-file-type nil) - (and vm-xemacs-mule-p - (set-buffer-file-coding-system 'no-conversion nil)) (write-region (point-min) (point-max) (concat "/tmp/Mosaic." pid) nil 0) @@ -232,12 +210,9 @@ (not (equal 0 (vm-run-command "kill" "-USR1" pid)))) (setq new-mosaic t))))) (if new-mosaic - (apply 'vm-run-background-command vm-mosaic-program - (append vm-mosaic-program-switches (list url)))) - (message "Sending URL to Mosaic... done")) + (vm-run-background-command vm-mosaic-program url)) + (vm-unsaved-message "Sending URL to Mosaic... done")) -(defun vm-mouse-send-url-to-mosaic-new-window (url) - (vm-mouse-send-url-to-mosaic url nil t)) (defun vm-mouse-install-mouse () (cond ((vm-mouse-xemacs-mouse-p) @@ -246,7 +221,7 @@ ((vm-mouse-fsfemacs-mouse-p) (if (null (lookup-key vm-mode-map [mouse-2])) (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) - (if vm-popup-menu-on-mouse-3 + (if (null (lookup-key vm-mode-map [down-mouse-3])) (progn (define-key vm-mode-map [mouse-3] 'ignore) (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) @@ -257,39 +232,6 @@ (defun vm-run-command (command &rest arg-list) (apply (function call-process) command nil nil nil arg-list)) -;; return t on zero exit status -;; return (exit-status . stderr-string) on nonzero exit status -(defun vm-run-command-on-region (start end output-buffer command - &rest arg-list) - (let ((tempfile nil) - ;; for DOS/Windows command to tell it that its input is - ;; binary. - (binary-process-input t) - status errstring) - (unwind-protect - (progn - (setq tempfile (vm-make-tempfile-name)) - (setq status - (apply 'call-process-region - start end command nil - (list output-buffer tempfile) - nil arg-list)) - (cond ((equal status 0) t) - ;; even if exit status non-zero, if there was no - ;; diagnostic output the command probably - ;; succeeded. I have tried to just use exit status - ;; as the failure criterion and users complained. - ((equal (nth 7 (file-attributes tempfile)) 0) - (message "%s exited non-zero (code %s)" command status) - t) - (t (save-excursion - (message "%s exited non-zero (code %s)" command status) - (set-buffer (find-file-noselect tempfile)) - (setq errstring (buffer-string)) - (kill-buffer nil) - (cons status errstring))))) - (vm-error-free-call 'delete-file tempfile)))) - ;; stupid yammering compiler (defvar vm-mouse-read-file-name-prompt) (defvar vm-mouse-read-file-name-dir) @@ -324,10 +266,8 @@ (setq vm-mouse-read-file-name-history history) (setq vm-mouse-read-file-name-prompt prompt) (setq vm-mouse-read-file-name-return-value nil) - (if (and vm-mutable-frames vm-frame-per-completion - (vm-multiple-frames-possible-p)) - (save-excursion - (vm-goto-new-frame 'completion))) + (save-excursion + (vm-goto-new-frame 'completion)) (switch-to-buffer (current-buffer)) (vm-mouse-read-file-name-event-handler) (save-excursion @@ -346,15 +286,17 @@ (cond ((equal string key-doc) (condition-case nil (save-excursion + (save-excursion + (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on (current-buffer)))) (setq vm-mouse-read-file-name-return-value - (save-excursion - (vm-keyboard-read-file-name - vm-mouse-read-file-name-prompt - vm-mouse-read-file-name-dir - vm-mouse-read-file-name-default - vm-mouse-read-file-name-must-match - vm-mouse-read-file-name-initial - vm-mouse-read-file-name-history))) + (vm-keyboard-read-file-name + vm-mouse-read-file-name-prompt + vm-mouse-read-file-name-dir + vm-mouse-read-file-name-default + vm-mouse-read-file-name-must-match + vm-mouse-read-file-name-initial + vm-mouse-read-file-name-history)) (vm-mouse-read-file-name-quit-handler t)) (quit (vm-mouse-read-file-name-quit-handler)))) ((file-directory-p string) @@ -379,18 +321,17 @@ (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n ?\n) - (setq list (vm-delete-backup-file-names - (vm-delete-auto-save-file-names - (directory-files default-directory)))) + (setq list (directory-files default-directory)) (vm-show-list list 'vm-mouse-read-file-name-event-handler) (setq buffer-read-only t))) (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit) (interactive) - (vm-maybe-delete-windows-or-frames-on (current-buffer)) - (if normal-exit - (throw 'exit nil) - (throw 'exit t))) + (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on (current-buffer)) + (if normal-exit + (throw 'exit nil) + (throw 'exit t)))) (defvar vm-mouse-read-string-prompt) (defvar vm-mouse-read-string-completion-list) @@ -410,10 +351,8 @@ (setq vm-mouse-read-string-completion-list completion-list) (setq vm-mouse-read-string-multi-word multi-word) (setq vm-mouse-read-string-return-value nil) - (if (and vm-mutable-frames vm-frame-per-completion - (vm-multiple-frames-possible-p)) - (save-excursion - (vm-goto-new-frame 'completion))) + (save-excursion + (vm-goto-new-frame 'completion)) (switch-to-buffer (current-buffer)) (vm-mouse-read-string-event-handler) (save-excursion @@ -430,12 +369,15 @@ (defun vm-mouse-read-string-event-handler (&optional string) (let ((key-doc "Click here for keyboard interface.") (bs-doc " .... to go back one word.") - (done-doc " .... when you're done.") + (done-doc " .... to when you're done.") start list) (if string (cond ((equal string key-doc) (condition-case nil (save-excursion + (save-excursion + (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on (current-buffer)))) (setq vm-mouse-read-string-return-value (vm-keyboard-read-string vm-mouse-read-string-prompt @@ -486,7 +428,8 @@ (defun vm-mouse-read-string-quit-handler (&optional normal-exit) (interactive) - (vm-maybe-delete-windows-or-frames-on (current-buffer)) - (if normal-exit - (throw 'exit nil) - (throw 'exit t))) + (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on (current-buffer)) + (if normal-exit + (throw 'exit nil) + (throw 'exit t))))