| 1 | ;;; gnus-dired.el --- utility functions where gnus and dired meet |
| 2 | |
| 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Authors: Benjamin Rutt <brutt@bloomington.in.us>, |
| 7 | ;; Shenghuo Zhu <zsh@cs.rochester.edu> |
| 8 | ;; Keywords: mail, news, extensions |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or |
| 15 | ;; (at your option) any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;; This package provides utility functions for intersections of gnus |
| 28 | ;; and dired. To enable the gnus-dired-mode minor mode which will |
| 29 | ;; have the effect of installing keybindings in dired-mode, place the |
| 30 | ;; following in your ~/.gnus: |
| 31 | |
| 32 | ;; (require 'gnus-dired) ;, isn't needed due to autoload cookies |
| 33 | ;; (add-hook 'dired-mode-hook 'turn-on-gnus-dired-mode) |
| 34 | |
| 35 | ;; Note that if you visit dired buffers before your ~/.gnus file has |
| 36 | ;; been read, those dired buffers won't have the keybindings in |
| 37 | ;; effect. To get around that problem, you may want to add the above |
| 38 | ;; statements to your ~/.emacs instead. |
| 39 | |
| 40 | ;;; Code: |
| 41 | |
| 42 | (eval-when-compile |
| 43 | (when (featurep 'xemacs) |
| 44 | (require 'easy-mmode))) ; for `define-minor-mode' |
| 45 | (require 'dired) |
| 46 | (autoload 'mml-attach-file "mml") |
| 47 | (autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'? |
| 48 | (autoload 'mailcap-extension-to-mime "mailcap") |
| 49 | (autoload 'mailcap-mime-info "mailcap") |
| 50 | |
| 51 | ;; Maybe shift this function to `mailcap.el'? |
| 52 | (autoload 'mm-mailcap-command "mm-decode") |
| 53 | |
| 54 | (autoload 'ps-print-preprint "ps-print") |
| 55 | |
| 56 | ;; Autoloads to avoid byte-compiler warnings. These are used only if the user |
| 57 | ;; customizes `gnus-dired-mail-mode' to use Message and/or Gnus. |
| 58 | (autoload 'message-buffers "message") |
| 59 | (autoload 'gnus-print-buffer "gnus-sum") |
| 60 | |
| 61 | (defvar gnus-dired-mode-map |
| 62 | (let ((map (make-sparse-keymap))) |
| 63 | (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach) |
| 64 | (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) |
| 65 | (define-key map "\C-c\C-m\C-p" 'gnus-dired-print) |
| 66 | map)) |
| 67 | |
| 68 | ;; FIXME: Make it customizable, change the default to `mail-user-agent' when |
| 69 | ;; this file is renamed (e.g. to `dired-mime.el'). |
| 70 | |
| 71 | (defcustom gnus-dired-mail-mode 'gnus-user-agent ;; mail-user-agent |
| 72 | "Your preference for a mail composition package. |
| 73 | See `mail-user-agent' for more information." |
| 74 | :group 'mail ;; dired? |
| 75 | :version "23.1" ;; No Gnus |
| 76 | :type '(radio (function-item :tag "Default Emacs mail" |
| 77 | :format "%t\n" |
| 78 | sendmail-user-agent) |
| 79 | (function-item :tag "Emacs interface to MH" |
| 80 | :format "%t\n" |
| 81 | mh-e-user-agent) |
| 82 | (function-item :tag "Gnus Message package" |
| 83 | :format "%t\n" |
| 84 | message-user-agent) |
| 85 | (function-item :tag "Gnus Message with full Gnus features" |
| 86 | :format "%t\n" |
| 87 | gnus-user-agent) |
| 88 | (function :tag "Other"))) |
| 89 | |
| 90 | (eval-when-compile |
| 91 | (when (featurep 'xemacs) |
| 92 | (defvar gnus-dired-mode-hook) |
| 93 | (defvar gnus-dired-mode-on-hook) |
| 94 | (defvar gnus-dired-mode-off-hook))) |
| 95 | |
| 96 | (define-minor-mode gnus-dired-mode |
| 97 | "Minor mode for intersections of gnus and dired. |
| 98 | |
| 99 | \\{gnus-dired-mode-map}" |
| 100 | :keymap gnus-dired-mode-map |
| 101 | (unless (derived-mode-p 'dired-mode) |
| 102 | (setq gnus-dired-mode nil))) |
| 103 | |
| 104 | ;;;###autoload |
| 105 | (defun turn-on-gnus-dired-mode () |
| 106 | "Convenience method to turn on gnus-dired-mode." |
| 107 | (interactive) |
| 108 | (gnus-dired-mode 1)) |
| 109 | |
| 110 | (defun gnus-dired-mail-buffers () |
| 111 | "Return a list of active mail composition buffers." |
| 112 | (if (and (memq gnus-dired-mail-mode '(message-user-agent gnus-user-agent)) |
| 113 | (require 'message) |
| 114 | (fboundp 'message-buffers)) |
| 115 | (message-buffers) |
| 116 | ;; Cf. `message-buffers' in `message.el': |
| 117 | (let (buffers) |
| 118 | (save-excursion |
| 119 | (dolist (buffer (buffer-list t)) |
| 120 | (set-buffer buffer) |
| 121 | (when (eq major-mode 'mail-mode) |
| 122 | (push (buffer-name buffer) buffers)))) |
| 123 | (nreverse buffers)))) |
| 124 | |
| 125 | ;; Method to attach files to a mail composition. |
| 126 | (defun gnus-dired-attach (files-to-attach) |
| 127 | "Attach dired's marked files to a gnus message composition. |
| 128 | If called non-interactively, FILES-TO-ATTACH should be a list of |
| 129 | filenames." |
| 130 | (interactive |
| 131 | (list |
| 132 | (delq nil |
| 133 | (mapcar |
| 134 | ;; don't attach directories |
| 135 | (lambda (f) (if (file-directory-p f) nil f)) |
| 136 | (nreverse |
| 137 | (let ((arg nil)) ;; Silence XEmacs 21.5 when compiling. |
| 138 | (dired-map-over-marks (dired-get-filename) arg))))))) |
| 139 | (let ((destination nil) |
| 140 | (files-str nil) |
| 141 | (bufs nil)) |
| 142 | ;; warn if user tries to attach without any files marked |
| 143 | (if (null files-to-attach) |
| 144 | (error "No files to attach") |
| 145 | (setq files-str |
| 146 | (mapconcat |
| 147 | (lambda (f) (file-name-nondirectory f)) |
| 148 | files-to-attach ", ")) |
| 149 | (setq bufs (gnus-dired-mail-buffers)) |
| 150 | |
| 151 | ;; set up destination mail composition buffer |
| 152 | (if (and bufs |
| 153 | (y-or-n-p "Attach files to existing mail composition buffer? ")) |
| 154 | (setq destination |
| 155 | (if (= (length bufs) 1) |
| 156 | (get-buffer (car bufs)) |
| 157 | (gnus-completing-read "Attach to which mail composition buffer" |
| 158 | bufs t))) |
| 159 | ;; setup a new mail composition buffer |
| 160 | (let ((mail-user-agent gnus-dired-mail-mode) |
| 161 | ;; A workaround to prevent Gnus from displaying the Gnus |
| 162 | ;; logo when invoking this command without loading Gnus. |
| 163 | ;; Gnus demonstrates it when gnus.elc is being loaded if |
| 164 | ;; a command of which the name is prefixed with "gnus" |
| 165 | ;; causes that autoloading. See the code in question, |
| 166 | ;; that is the one first found in gnus.el by performing |
| 167 | ;; `C-s this-command'. |
| 168 | (this-command (if (eq gnus-dired-mail-mode 'gnus-user-agent) |
| 169 | 'gnoose-dired-attach |
| 170 | this-command))) |
| 171 | (compose-mail)) |
| 172 | (setq destination (current-buffer))) |
| 173 | |
| 174 | ;; set buffer to destination buffer, and attach files |
| 175 | (set-buffer destination) |
| 176 | (goto-char (point-max)) ;attach at end of buffer |
| 177 | (while files-to-attach |
| 178 | (mml-attach-file (car files-to-attach) |
| 179 | (or (mm-default-file-encoding (car files-to-attach)) |
| 180 | "application/octet-stream") nil) |
| 181 | (setq files-to-attach (cdr files-to-attach))) |
| 182 | (message "Attached file(s) %s" files-str)))) |
| 183 | |
| 184 | (autoload 'mailcap-parse-mailcaps "mailcap" "" t) |
| 185 | |
| 186 | (defun gnus-dired-find-file-mailcap (&optional file-name arg) |
| 187 | "In dired, visit FILE-NAME according to the mailcap file. |
| 188 | If ARG is non-nil, open it in a new buffer." |
| 189 | (interactive (list |
| 190 | (file-name-sans-versions (dired-get-filename) t) |
| 191 | current-prefix-arg)) |
| 192 | (mailcap-parse-mailcaps) |
| 193 | (if (file-exists-p file-name) |
| 194 | (let (mime-type method) |
| 195 | (if (and (not arg) |
| 196 | (not (file-directory-p file-name)) |
| 197 | (string-match "\\.[^\\.]+$" file-name) |
| 198 | (setq mime-type |
| 199 | (mailcap-extension-to-mime |
| 200 | (match-string 0 file-name))) |
| 201 | (stringp |
| 202 | (setq method |
| 203 | (cdr (assoc 'viewer |
| 204 | (car (mailcap-mime-info mime-type |
| 205 | 'all |
| 206 | 'no-decode))))))) |
| 207 | (let ((view-command (mm-mailcap-command method file-name nil))) |
| 208 | (message "viewing via %s" view-command) |
| 209 | (start-process "*display*" |
| 210 | nil |
| 211 | shell-file-name |
| 212 | shell-command-switch |
| 213 | view-command)) |
| 214 | (find-file file-name))) |
| 215 | (if (file-symlink-p file-name) |
| 216 | (error "File is a symlink to a nonexistent target") |
| 217 | (error "File no longer exists; type `g' to update Dired buffer")))) |
| 218 | |
| 219 | (defun gnus-dired-print (&optional file-name print-to) |
| 220 | "In dired, print FILE-NAME according to the mailcap file. |
| 221 | |
| 222 | If there is no print command, print in a PostScript image. If the |
| 223 | optional argument PRINT-TO is nil, send the image to the printer. If |
| 224 | PRINT-TO is a string, save the PostScript image in a file with that |
| 225 | name. If PRINT-TO is a number, prompt the user for the name of the |
| 226 | file to save in." |
| 227 | (interactive (list |
| 228 | (file-name-sans-versions (dired-get-filename) t) |
| 229 | (ps-print-preprint current-prefix-arg))) |
| 230 | (mailcap-parse-mailcaps) |
| 231 | (cond |
| 232 | ((file-directory-p file-name) |
| 233 | (error "Can't print a directory")) |
| 234 | ((file-exists-p file-name) |
| 235 | (let (mime-type method) |
| 236 | (if (and (string-match "\\.[^\\.]+$" file-name) |
| 237 | (setq mime-type |
| 238 | (mailcap-extension-to-mime |
| 239 | (match-string 0 file-name))) |
| 240 | (stringp |
| 241 | (setq method (mailcap-mime-info mime-type "print" |
| 242 | 'no-decode)))) |
| 243 | (call-process shell-file-name nil |
| 244 | (generate-new-buffer " *mm*") |
| 245 | nil |
| 246 | shell-command-switch |
| 247 | (mm-mailcap-command method file-name mime-type)) |
| 248 | (with-temp-buffer |
| 249 | (insert-file-contents file-name) |
| 250 | (if (eq gnus-dired-mail-mode 'gnus-user-agent) |
| 251 | (gnus-print-buffer) |
| 252 | ;; FIXME: |
| 253 | (error "MIME print only implemeted via Gnus"))) |
| 254 | (ps-despool print-to)))) |
| 255 | ((file-symlink-p file-name) |
| 256 | (error "File is a symlink to a nonexistent target")) |
| 257 | (t |
| 258 | (error "File no longer exists; type `g' to update Dired buffer")))) |
| 259 | |
| 260 | (provide 'gnus-dired) |
| 261 | |
| 262 | ;;; gnus-dired.el ends here |